4632N/A{- |

4632N/AModule : $Header$

4632N/ADescription : printing Isabelle entities

4632N/ACopyright : (c) University of Cambridge, Cambridge, England

4632N/A adaption (c) Till Mossakowski, Uni Bremen 2002-2006

4632N/ALicense : GPLv2 or higher, see LICENSE.txt

4632N/A

4632N/AMaintainer : Christian.Maeder@dfki.de

4632N/AStability : provisional

4632N/APortability : portable

4632N/A

4632N/APrinting functions for Isabelle logic.

4632N/A-}

4632N/A

4632N/Amodule Isabelle.IsaPrint

4632N/A ( showBaseSig

4632N/A , printIsaTheory

4632N/A , getAxioms

4632N/A , printNamedSen

4632N/A , printTerm

4632N/A ) where

4632N/A

4632N/Aimport Isabelle.IsaSign

4632N/Aimport Isabelle.IsaConsts

4632N/Aimport Isabelle.Translate

4632N/A

4632N/Aimport Common.AS_Annotation

4632N/Aimport qualified Data.Map as Map

4632N/Aimport qualified Data.Set as Set

4632N/Aimport Common.Doc hiding (bar)

4632N/Aimport Common.DocUtils

4632N/Aimport Common.Utils (number)

4632N/A

4632N/Aimport Data.Char

4632N/Aimport Data.List

4632N/Aimport Data.Maybe (catMaybes)

4632N/A

4632N/AprintIsaTheory :: String -> Sign -> [Named Sentence] -> Doc

4632N/AprintIsaTheory tn sign sens = let

4632N/A b = baseSig sign

4632N/A bs = showBaseSig b

4632N/A ld = "$HETS_ISABELLE_LIB/"

4632N/A use = text usesS <+> doubleQuotes (text $ ld ++ "prelude.ML")

4632N/A in text theoryS <+> text tn

4632N/A $+$ text importsS <+> fsep ((if case b of

4632N/A Main_thy -> False

4632N/A HOLCF_thy -> False

4632N/A _ -> True then doubleQuotes $ text $ ld ++ bs else text bs)

4632N/A : map (doubleQuotes . text) (imports sign))

4632N/A $+$ use

4632N/A $+$ text beginS

4632N/A $++$ printTheoryBody sign sens

4632N/A $++$ text endS

4632N/A

4632N/AprintTheoryBody :: Sign -> [Named Sentence] -> Doc

4632N/AprintTheoryBody sig sens =

4632N/A let (sens',recFuns) = findTypesForRecFuns sens (constTab sig)

4632N/A sig' = sig { constTab =

4632N/A Map.filterWithKey (\k _ -> not $ (new k) `elem` recFuns) (constTab sig) }

4632N/A in callSetup "initialize" (brackets $ sepByCommas

4632N/A $ map (text . show . Quote . senAttr)

4632N/A $ filter (\ s -> not (isConstDef s || isRecDef s || isInstance s)

4632N/A && senAttr s /= "") sens')

4632N/A $++$ printSign sig'

4632N/A $++$ printNamedSentences sens'

4632N/A $++$ printMonSign sig'

4632N/A

4632N/AfindTypesForRecFuns :: [Named Sentence] -> ConstTab

4632N/A -> ([Named Sentence], [String])

4632N/AfindTypesForRecFuns ns ctab =

4632N/A let (sens,recFuns') = unzip $ map (\ sen ->

4632N/A let (sen',recFns') =

4632N/A case sentence sen of

4632N/A RecDef kw cName cType tm ->

4632N/A ((case Map.toList $

4632N/A Map.filterWithKey (\k _ -> (new k) == (new cName)) ctab of

4632N/A (_,t):_ ->

4632N/A case cType of

4632N/A Nothing ->

4632N/A RecDef kw cName (Just t) tm

4632N/A Just t' ->

4632N/A if t /= t' then error "recFun: two types given"

4632N/A else sentence sen

4632N/A [] -> sentence sen),

4632N/A Just cName)

4632N/A _ -> (sentence sen,Nothing)

4632N/A in (sen {sentence=sen'},recFns')) ns

4632N/A in (sens,map new $ catMaybes recFuns')

4632N/A

4632N/AprintNamedSentences :: [Named Sentence] -> Doc

4632N/AprintNamedSentences sens = case sens of

4632N/A [] -> empty

4632N/A s : r

4632N/A | isIsaAxiom s ->

4632N/A let (axs, rest) = span isAxiom sens in

4632N/A text axiomsS $+$ vsep (map printNamedSen axs)

4632N/A $++$ vcat (map ( \ a -> text declareS <+> text (senAttr a)

4632N/A <+> brackets (text simpS))

4632N/A $ filter ( \ a -> case sentence a of

4632N/A b@Sentence {} -> isSimp b && senAttr a /= ""

4632N/A _ -> False) axs)

4632N/A $++$ printNamedSentences rest

4632N/A | isConstDef s ->

4632N/A let (defs, rest) = span isConstDef sens in

4632N/A text defsS $+$ vsep (map printNamedSen defs)

4632N/A $++$ printNamedSentences rest

4632N/A | otherwise ->

4632N/A printNamedSen s $++$ (case senAttr s of

4632N/A n | n == "" || isRecDef s -> empty

4632N/A | otherwise -> callSetup "record" (text $ show $ Quote n))

4632N/A $++$ printNamedSentences r

4632N/A

4632N/AcallSetup :: String -> Doc -> Doc

4632N/AcallSetup fun args =

4632N/A text "setup" <+> doubleQuotes (fsep [text ("Header." ++ fun), args])

4632N/A

4632N/Adata QuotedString = Quote String

4632N/Ainstance Show QuotedString where

4632N/A show (Quote s) = init . tail . show $ show s

4632N/A

4632N/AgetAxioms :: [Named Sentence] -> ([Named Sentence], [Named Sentence])

4632N/AgetAxioms = partition isIsaAxiom

4632N/A

4632N/AisIsaAxiom :: Named Sentence -> Bool

4632N/AisIsaAxiom s = case sentence s of

4632N/A Sentence {} -> isAxiom s

4632N/A _ -> False

4632N/A

4632N/AisInstance :: Named Sentence -> Bool

4632N/AisInstance s = case sentence s of

4632N/A Instance {} -> True

4632N/A _ -> False

4632N/A

4632N/AisConstDef :: Named Sentence -> Bool

4632N/AisConstDef s = case sentence s of

4632N/A ConstDef {} -> True

4632N/A _ -> False

4632N/A

4632N/AisRecDef :: Named Sentence -> Bool

4632N/AisRecDef s = case sentence s of

4632N/A RecDef {} -> True

4632N/A _ -> False

4632N/A

4632N/A-- --------------------- Printing functions -----------------------------

4632N/A

4632N/AshowBaseSig :: BaseSig -> String

4632N/AshowBaseSig = takeWhile (/= '_') . show

4632N/A

4632N/AprintClass :: IsaClass -> Doc

4632N/AprintClass (IsaClass x) = text x

4632N/A

4632N/AprintSort :: Sort -> Doc

4632N/AprintSort = printSortAux False

4632N/A

4632N/AprintSortAux :: Bool -> Sort -> Doc

4632N/AprintSortAux b l = case l of

4632N/A [c] -> printClass c

4632N/A _ -> (if b then doubleQuotes else id)

4632N/A . braces . hcat . punctuate comma $ map printClass l

4632N/A

4632N/Adata SynFlag = Quoted | Unquoted | Null

4632N/A

4632N/AdoubleColon :: Doc

4632N/AdoubleColon = text "::"

4632N/A

4632N/AisaEquals :: Doc

4632N/AisaEquals = text "=="

4632N/A

4632N/Abar :: [Doc] -> [Doc]

4632N/Abar = punctuate $ space <> text "|"

4632N/A

4632N/AprintType :: Typ -> Doc

4632N/AprintType = printTyp Unquoted

4632N/A

4632N/AprintTyp :: SynFlag -> Typ -> Doc

4632N/AprintTyp a = fst . printTypeAux a

4632N/A

4632N/AprintTypeAux :: SynFlag -> Typ -> (Doc, Int)

4632N/AprintTypeAux a t = case t of

4632N/A TFree v s -> (let

4632N/A d = text $ if isPrefixOf "\'" v || isPrefixOf "?\'" v

4632N/A then v else '\'' : v

4632N/A c = printSort s

4632N/A in if null s then d else case a of

4632N/A Quoted -> d <> doubleColon <> if null

4632N/A $ tail s then c else doubleQuotes c

4632N/A Unquoted -> d <> doubleColon <> c

4632N/A Null -> d, 1000)

4632N/A TVar iv s -> printTypeAux a $ TFree (unindexed iv) s

4632N/A Type name _ args -> case args of

4632N/A [t1, t2] | elem name [prodS, sProdS, funS, cFunS, lFunS, sSumS] ->

4632N/A printTypeOp a name t1 t2

4632N/A _ -> ((case args of

4632N/A [] -> empty

4632N/A [arg] -> let (d, i) = printTypeAux a arg in

if i < 1000 then parens d else d

_ -> parens $ hsep $ punctuate comma $

map (fst . printTypeAux a) args)

<+> text name, 1000)

printTypeOp :: SynFlag -> TName -> Typ -> Typ -> (Doc, Int)

printTypeOp x name r1 r2 =

let (d1, i1) = printTypeAux x r1

(d2, i2) = printTypeAux x r2

(l, r) = Map.findWithDefault (0 :: Int, 0 :: Int)

name $ Map.fromList

[ (funS, (1, 0))

, (cFunS, (1, 0))

, (lFunS, (1, 0))

, (sSumS, (11, 10))

, (prodS, (21, 20))

, (sProdS, (21, 20))

, (lProdS, (21, 20))

]

d3 = if i1 < l then parens d1 else d1

d4 = if i2 < r then parens d2 else d2

in (d3 <+> text name <+> d4, r)

and_docs :: [Doc] -> Doc

and_docs ds = vcat $ prepPunctuate (text andS <> space) ds

-- | printing a named sentence

printNamedSen :: Named Sentence -> Doc

printNamedSen ns =

let s = sentence ns

lab = senAttr ns

b = isAxiom ns

d = printSentence s

in case s of

TypeDef {} -> d

RecDef {} -> d

Lemmas {} -> d

Instance {} -> d

_ -> let dd = doubleQuotes d in

if isRefute s then text lemmaS <+> text lab <+> colon

<+> dd $+$ text refuteS

else if null lab then dd else fsep [ (case s of

ConstDef {} -> text $ lab ++ "_def"

Sentence {} ->

(if b then empty else text theoremS)

<+> text lab <+> (if b then text "[rule_format]" else

if isSimp s then text "[simp]" else empty)

_ -> error "printNamedSen") <+> colon, dd] $+$ case s of

Sentence {} -> if b then empty else case thmProof s of

Nothing -> text oopsS

Just prf -> pretty prf

_ -> empty

-- | sentence printing

printSentence :: Sentence -> Doc

printSentence s = case s of

TypeDef nt td pr -> text typedefS

<+> printType nt

<+> equals

<+> doubleQuotes (printSetDecl td)

$+$ pretty pr

RecDef kw cName cType xs ->

let preparedEq = map (doubleQuotes . printTerm) xs

preparedEqWithBars =

map (<+> text barS) (init preparedEq) ++ [last preparedEq]

tp = case cType of

Just t -> doubleColon <+> doubleQuotes (printType t)

Nothing -> empty

kw' = case kw of

Just str -> text str

Nothing -> text primrecS

in kw' <+> text (new cName) <+> tp <+> printAlt cName <+> text whereS $+$

vcat preparedEqWithBars

Instance { tName = t, arityArgs = args, arityRes = res, definitions = defs,

instProof = prf } ->

text instantiationS <+> text t <> doubleColon <> (case args of

[] -> empty

_ -> parens $ hsep $ punctuate comma $ map (printSortAux True) args)

<+> printSortAux True res $+$ text beginS $++$ printDefs defs $++$

text instanceS <+> pretty prf $+$ text endS

where printDefs :: [(String, Term)] -> Doc

printDefs defs' = vcat (map printDef defs')

printDef :: (String, Term) -> Doc

printDef (name, def) =

text definitionS <+>

printNamedSen (makeNamed name (ConstDef def))

Sentence { isRefuteAux = b, metaTerm = t } -> printPlainMetaTerm (not b) t

ConstDef t -> printTerm t

Lemmas name lemmas -> if null lemmas

then empty {- only have this lemmas if we have some in

the list -}

else text lemmasS <+> text name <+>

equals <+> sep (map text lemmas)

printSetDecl :: SetDecl -> Doc

printSetDecl setdecl =

case setdecl of

SubSet v t f -> braces $ printTerm v <> doubleColon <> printType t <> dot

<+> printTerm f

FixedSet elems -> braces $ sepByCommas $ map printTerm elems

printPlainMetaTerm :: Bool -> MetaTerm -> Doc

printPlainMetaTerm b mt = case mt of

Term t -> printPlainTerm b t

Conditional conds t -> sep

[ text premiseOpenS

<+> fsep (punctuate semi $ map printTerm conds)

<+> text premiseCloseS

, text metaImplS <+> printTerm t ]

-- | print plain term

printTerm :: Term -> Doc

printTerm = printPlainTerm True

printPlainTerm :: Bool -> Term -> Doc

printPlainTerm b = fst . printTrm b

-- | print parens but leave a space if doc starts or ends with a bar

parensForTerm :: Doc -> Doc

parensForTerm d =

let s = show d

b = '|'

in parens $ if null s then d

else (if head s == b then (space <>) else id)

((if last s == b then (<> space) else id) d)

printParenTerm :: Bool -> Int -> Term -> Doc

printParenTerm b i t = case printTrm b t of

(d, j) -> if j < i then parensForTerm d else d

flatTuplex :: [Term] -> Continuity -> [Term]

flatTuplex cs c = case cs of

[] -> cs

_ -> case last cs of

Tuplex rs@(_ : _ : _) d | d == c -> init cs ++ flatTuplex rs d

_ -> cs

printMixfixAppl :: Bool -> Continuity -> Term -> [Term] -> (Doc, Int)

printMixfixAppl b c f args = case f of

Const (VName n (Just (AltSyntax s is i))) (Hide _ _ _) ->

if length is == length args &&

(b || n == cNot || isPrefixOf "op " n) then

(fsep $ replaceUnderlines s

$ zipWith (printParenTerm b) is args, i)

else printApp b c f args

Const vn _ | new vn `elem` [allS, exS, ex1S] -> case args of

[Abs v t _] -> (fsep [text (new vn) <+> printPlainTerm False v

<> dot

, printPlainTerm b t], lowPrio)

_ -> printApp b c f args

App g a d | c == d -> printMixfixAppl b c g (a : args)

_ -> printApp b c f args

-- | print the term using the alternative syntax (if True)

printTrm :: Bool -> Term -> (Doc, Int)

printTrm b trm = case trm of

Const vn ty -> let

dvn = text $ new vn

nvn = case ty of

Hide _ _ _ -> dvn

Disp w _ _ -> parens $ dvn <+> doubleColon <+> printType w

in case altSyn vn of

Nothing -> (nvn, maxPrio)

Just (AltSyntax s is i) -> if b && null is then

(fsep $ replaceUnderlines s [], i) else (nvn, maxPrio)

Free vn -> (text $ new vn, maxPrio)

Abs v t c -> (text (case c of

NotCont -> "%"

IsCont _ -> "Lam") <+> printPlainTerm False v <> dot

<+> printPlainTerm b t, lowPrio)

If i t e c -> let d = fsep [printPlainTerm b i,

text (case c of

NotCont -> "then"

IsCont _ -> "THEN")

<+> printPlainTerm b t,

text (case c of

NotCont -> "else"

IsCont _ -> "ELSE")

<+> printPlainTerm b e]

in case c of

NotCont -> (text "if" <+> d, lowPrio)

IsCont _ -> (text "IF" <+> d <+> text "FI", maxPrio)

Case e ps -> (text "case" <+> printPlainTerm b e <+> text "of"

$+$ vcat (bar $ map (\ (p, t) ->

fsep [ printPlainTerm b p <+> text "=>"

, printParenTerm b (lowPrio + 1) t]) ps), lowPrio)

Let es i -> (fsep [text "let" <+>

vcat (punctuate semi $

map (\ (p, t) -> fsep [ printPlainTerm b p <+> equals

, printPlainTerm b t]) es)

, text "in" <+> printPlainTerm b i], lowPrio)

IsaEq t1 t2 ->

(fsep [ printParenTerm b (isaEqPrio + 1) t1 <+> isaEquals

, printParenTerm b isaEqPrio t2], isaEqPrio)

Tuplex cs c -> case c of

NotCont -> (parensForTerm

$ sepByCommas (map (printPlainTerm b)

$ flatTuplex cs c)

, maxPrio)

IsCont _ -> case cs of

[] -> error "IsaPrint, printTrm"

[a] -> printTrm b a

a : aa -> printTrm b $ App (App

lpairTerm a $ IsCont False)

(Tuplex aa c) (IsCont False)

App f a c -> printMixfixAppl b c f [a]

Set setdecl -> (printSetDecl setdecl, lowPrio)

printApp :: Bool -> Continuity -> Term -> [Term] -> (Doc, Int)

printApp b c t l = case l of

[] -> printTrm b t

_ -> printDocApp b c (printParenTerm b (maxPrio - 1) t) l

printDocApp :: Bool -> Continuity -> Doc -> [Term] -> (Doc, Int)

printDocApp b c d l =

( fsep $ (case c of

NotCont -> id

IsCont True -> punctuate $ text " $$"

IsCont False -> punctuate $ text " $")

$ d : map (printParenTerm b maxPrio) l

, maxPrio - 1)

replaceUnderlines :: String -> [Doc] -> [Doc]

replaceUnderlines str l = case str of

"" -> []

'\'' : r@(q : s) -> if q `elem` "_/'()"

then consDocBarSep (text [q]) $ replaceUnderlines s l

else consDocBarSep (text "'") $ replaceUnderlines r l

'_' : r -> case l of

h : t -> consDocBarSep h $ replaceUnderlines r t

_ -> error "replaceUnderlines"

'/' : ' ' : r -> empty : replaceUnderlines r l

q : r -> if q `elem` "()/" then replaceUnderlines r l

else consDocBarSep (text [q]) $ replaceUnderlines r l

consDocBarSep :: Doc -> [Doc] -> [Doc]

consDocBarSep d r = case r of

[] -> [d]

h : t -> let

b = '|'

hs = show h

ds = show d

hhs = head hs

lds = last ds

in if null hs || null ds then (d <> h) : t else

if hhs == b && lds == '(' || last ds == b && hhs == ')'

then (d <+> h) : t

else (d <> h) : t

-- end of term printing

printLocales :: Locales -> Doc

printLocales = vsep . map printLocale . orderLDecs . Map.toList

printLocale :: (String,LocaleDecl) -> Doc

printLocale (n,(parents,in_ax,ex_ax,params)) =

let p' = Data.List.intersperse (text "+") $ map text parents

a = map (\ (s,t) -> text s <+> text ":"

<+> (doubleQuotes . printTerm) t) in_ax

a' = if null a then []

else (head a):(map (text "and" <+>) (tail a))

f = map (\ (s,t,alt) -> text s <+> text "::"

<+> (doubleQuotes . (printTyp Null)) t

<+> (case alt of

Just (AltSyntax s' [i1,i2] i) -> parens ((

if i1==i2 then text "infix "

else if i1 < i2 then text "infixr "

else text "infixl ") <+> doubleQuotes (text s')

<+> text (show i))

_ -> empty

)) params

f' = if null f then []

else (head f):(map (text "and" <+>) (tail f))

in vcat [

vcat [text "locale" <+> text n <+>

(if length (p'++a'++f') > 0

then text "=" else empty) <+>

hsep p' <+> if length p' > 0 &&

(length a' > 0 || length f' > 0)

then text "+" else empty,

(if length f' > 0 then text "fixes" else empty) <+> vcat f',

(if length a' > 0 then text "assumes" else empty) <+> vcat a'],

vcat (map (\ (s,t) -> text ("theorem (in "++ n ++")")

<+> text s <+> text ":"

<+> (doubleQuotes . printTerm) t) ex_ax)]

printClassrel :: Classrel -> Doc

printClassrel = vsep . map printClassR . orderCDecs . Map.toList

printClassR :: (IsaClass,ClassDecl) -> Doc

printClassR (y, (parents, assumptions,fixes)) =

let a = map (\ (s,t) -> text s <+> text ":"

<+> (doubleQuotes . printTerm) t) assumptions

a' = if null a then []

else (head a):(map (text "and" <+>) (tail a))

f = map (\ (s,t) -> text s <+> text "::"

<+> (doubleQuotes . (printTyp Null)) t) fixes

f' = if null f then []

else (head f):(map (text "and" <+>) (tail f))

parents' = filter (\ (IsaClass s) -> not $ elem s

["HOL.type_class","HOL.type","type","type_class"]) parents

p' = Data.List.intersperse (text "+") $ map printClass parents'

in vcat [text "class" <+> printClass y <+>

(if length (p'++a'++f') > 0 then text "=" else empty)

<+> hsep p' <+> if length p' > 0 &&

(length a' > 0 || length f' > 0)

then text "+" else empty,

(if length f' > 0 then text "fixes" else empty) <+> vcat f',

(if length a' > 0 then text "assumes" else empty) <+> vcat a']

orderCDecs :: [(IsaClass,ClassDecl)] -> [(IsaClass,ClassDecl)]

orderCDecs =

topSort crord

where

crord (_,(cs,_,_)) (c,_) = elem c cs

orderLDecs :: [(String,LocaleDecl)] -> [(String,LocaleDecl)]

orderLDecs =

topSort crord

where

crord (_,(cs,_,_,_)) (c,_) = elem c cs

printMonArities :: String -> Arities -> Doc

printMonArities tn = vcat . map ( \ (t, cl) ->

vcat $ map (printThMorp tn t) cl) . Map.toList

printThMorp :: String -> TName -> (IsaClass, [(Typ, Sort)]) -> Doc

printThMorp tn t xs = case xs of

(IsaClass "Monad", _) ->

if isSuffixOf "_mh" tn || isSuffixOf "_mhc" tn

then printMInstance tn t

else error "IsaPrint, printInstance: monads not supported"

_ -> empty

printMInstance :: String -> TName -> Doc

printMInstance tn t = let nM = text (t ++ "_tm")

nM2 = text (t ++ "_tm2")

in prnThymorph nM "MonadType" tn t [("MonadType.M", "'a")] []

$+$ text "t_instantiate MonadOps mapping" <+> nM

$+$ text "renames:" <+>

brackMapList (\ x -> t ++ "_" ++ x)

[("MonadOpEta.eta", "eta"), ("MonadOpBind.bind", "bind")]

$+$ text "without_syntax"

$++$ text "defs "

$+$ text (t ++ "_eta_def:") <+> doubleQuotes

(text (t ++ "_eta") <+> isaEquals <+> text ("return_" ++ t))

$+$ text (t ++ "_bind_def:") <+> doubleQuotes

(text (t ++ "_bind") <+> isaEquals <+> text ("mbind_" ++ t))

$++$ lunitLemma t

$+$ runitLemma t

$+$ assocLemma t

$+$ etaInjLemma t

$++$ prnThymorph nM2 "MonadAxms" tn t [("MonadType.M", "'a")]

[("MonadOpEta.eta", t ++ "_eta"),

("MonadOpBind.bind", t ++ "_bind")]

$+$ text "t_instantiate Monad mapping" <+> nM2

$+$ text "renames:" <+>

brackMapList (\ x -> t ++ "_" ++ x)

[("Monad.kapp", "kapp"),

("Monad.lift", "lift"),

("Monad.lift", "lift"),

("Monad.mapF", "mapF"),

("Monad.bind'", "mbbind"),

("Monad.joinM", "joinM"),

("Monad.kapp2", "kapp2"),

("Monad.kapp3", "kapp3"),

("Monad.lift2", "lift2"),

("Monad.lift3", "lift3")]

$+$ text "without_syntax"

$++$ text " "

where

lunitLemma w = text lemmaS <+> text (w ++ "_lunit:")

<+> doubleQuotes (text (w ++ "_bind")

<+> parens (text (w ++ "_eta x"))

<+> parens (text $ "t::'a => 'b " ++ w)

<+> equals <+> text "t x")

$+$ text "sorry "

runitLemma w = text lemmaS <+> text (w ++ "_runit:")

<+> doubleQuotes (text (w ++ "_bind")

<+> parens (text $ "t::'a " ++ w) <+> text (w ++ "_eta")

<+> equals <+> text "t")

$+$ text "sorry "

assocLemma w = text lemmaS <+> text (w ++ "_assoc:")

<+> doubleQuotes (text (w ++ "_bind")

<+> parens (text (w ++ "_bind")

<+> parens (text $ "s::'a " ++ w) <+> text "t") <+> text "u"

<+> equals <+> text (w ++ "_bind s")

<+> parens (text "%x." <+>

text (w ++ "_bind") <+> text "(t x) u"))

$+$ text "sorry "

etaInjLemma w = text lemmaS <+> text (w ++ "_eta_inj:")

<+> doubleQuotes (parens (text $ w ++ "_eta::'a => 'a " ++ w)

<+> text "x"

<+> equals <+> text (w ++ "_eta y")

<+> text "==>" <+> text "x = y")

$+$ text "sorry "

prnThymorph :: Doc -> String -> String -> TName -> [(String, String)]

-> [(String, String)] -> Doc

prnThymorph nm xn tn t ts ws = let qual s = tn ++ "." ++ s in

text "thymorph" <+> nm <+> colon <+>

text xn <+> cfun <+> text tn

$+$ text " maps" <+> brackets

(hcat [ parens $ doubleQuotes (text b <+> text a) <+> mapsto

<+> doubleQuotes (text b <+> text (qual t))

| (a, b) <- ts])

$+$ brackMapList qual ws

brackMapList :: (String -> String) -> [(String, String)] -> Doc

brackMapList f ws = brackets $ hsep $ punctuate comma

[ parens $ doubleQuotes (text a) <+> mapsto <+> doubleQuotes (text $ f b)

| (a, b) <- ws]

-- filter out types that are given in the domain table

printTypeDecls :: BaseSig -> DomainTab -> Arities -> Doc

printTypeDecls bs odt ars =

let dt = Map.fromList $ map (\ (t, _) -> (typeId t, [])) $ concat odt

in vcat $ map (printTycon bs) $ Map.toList $ Map.difference ars dt

printTycon :: BaseSig -> (TName, [(IsaClass, [(Typ, Sort)])]) -> Doc

printTycon bs (t, arity') = case arity' of

[] -> error "IsaPrint.printTycon"

(_, rs) : _ ->

if Set.member t

$ Map.findWithDefault (error "Isabelle.printTycon") bs

$ preTypes isaPrelude

then empty else

text typedeclS <+>

(if null rs then empty else

parens $ hsep $ punctuate comma

$ map (text . ("'a" ++) . show . snd) $ number rs) <+> text t

-- | show alternative syntax (computed by comorphisms)

printAlt :: VName -> Doc

printAlt (VName _ altV) = case altV of

Nothing -> empty

Just (AltSyntax s is i) -> parens $ doubleQuotes (text s)

<+> if null is then empty else text (show is) <+>

if i == maxPrio then empty else text (show i)

instance Pretty Sign where

pretty = printSign

-- | a dummy constant table with wrong types

constructors :: DomainTab -> ConstTab

constructors = Map.fromList . map (\ v -> (v, noTypeT))

. concatMap (map fst . snd) . concat

printMonSign :: Sign -> Doc

printMonSign sig = let ars = arities $ tsig sig

in

printMonArities (theoryName sig) ars

printSign :: Sign -> Doc

printSign sig = let dt = ordDoms $ domainTab sig

ars = arities $ tsig sig

in

printAbbrs (abbrs $ tsig sig) $++$

printTypeDecls (baseSig sig) dt ars $++$

printLocales (locales $ tsig sig) $++$

printClassrel (classrel $ tsig sig) $++$

printDomainDefs dt $++$

printConstTab (Map.difference (constTab sig)

$ constructors dt) $++$

(if showLemmas sig

then showCaseLemmata dt else empty)

where

printAbbrs tab = if Map.null tab then empty else text typesS

$+$ vcat (map printAbbr $ Map.toList tab)

printAbbr (n, (vs, t)) = case vs of

[] -> empty

[x] -> text ('\'' : x)

_ -> parens $ hsep $ punctuate comma $

map (text . ('\'' :)) vs

<+> text n <+> equals <+> doubleQuotes (printType t)

printConstTab tab = if Map.null tab then empty else text constsS

$+$ vcat (map printConst $ Map.toList tab)

printConst (vn, t) = text (new vn) <+> doubleColon <+>

doubleQuotes (printType t) <+> printAlt vn

isDomain = case baseSig sig of

HOLCF_thy -> True

HsHOLCF_thy -> True

MHsHOLCF_thy -> True

_ -> False

printDomainDefs dtDefs = vcat $ map printDomainDef dtDefs

printDomainDef dts = if null dts then empty else

text (if isDomain then domainS else datatypeS)

<+> and_docs (map printDomain dts)

printDomain (t, ops) =

printTyp (if isDomain then Quoted else Null) t <+> equals <+>

fsep (bar $ map printDOp ops)

printDOp (vn, args) = let opname = new vn in

text (if any isSpace opname then show opname else opname)

<+> hsep (map (printDOpArg opname) $ number args)

<+> printAlt vn

printDOpArg o (a, i) = let

d = case a of

TFree _ _ -> printTyp Null a

_ -> doubleQuotes $ printTyp Null a

in if isDomain then

parens $ text "lazy" <+>

text (o ++ "_" ++ show i) <> doubleColon <> d

else d

showCaseLemmata dtDefs = text (concatMap showCaseLemmata1 dtDefs)

showCaseLemmata1 = concatMap showCaseLemma

showCaseLemma (_, []) = ""

showCaseLemma (tyCons, c : cns) =

let cs = "case caseVar of" ++ sp

sc b = showCons b c ++ concatMap ((" | " ++) . showCons b) cns

clSome = sc True

cl = sc False

showCons b (VName {new = cName}, args) =

let pat = cName ++ concatMap ((sp ++) . showArg) args

++ sp ++ "=>" ++ sp

term = showCaseTerm cName args

in

if b then pat ++ "Some" ++ sp ++ lb ++ term ++ rb ++ "\n"

else pat ++ term ++ "\n"

showCaseTerm name args = case name of

"" -> sa

n : _ -> toLower n : sa

where sa = concatMap ((sp ++) . showArg) args

showArg (TFree [] _) = "varName"

showArg (TFree (n : ns) _) = toLower n : ns

showArg (TVar v s) = showArg (TFree (unindexed v) s)

showArg (Type [] _ _) = "varName"

showArg (Type m@(n : ns) _ s) =

if elem m ["typeAppl", "fun", "*"]

then concatMap showArg s

else toLower n : ns

showName (TFree v _) = v

showName (TVar v _) = unindexed v

showName (Type n _ _) = n

proof' = "apply (case_tac caseVar)\napply (auto)\ndone\n"

in

lemmaS ++ sp ++ "case_" ++ showName tyCons ++ "_SomeProm" ++ sp

++ "[simp]:\"" ++ sp ++ lb ++ cs ++ clSome ++ rb ++ sp

++ "=\n" ++ "Some" ++ sp ++ lb ++ cs ++ cl ++ rb ++ "\"\n"

++ proof'

instance Pretty Sentence where

pretty = printSentence

sp :: String

sp = " "

rb :: String

rb = ")"

lb :: String

lb = "("

-- Pretty printing of proofs

instance Pretty IsaProof where

pretty = printIsaProof

printIsaProof :: IsaProof -> Doc

printIsaProof (IsaProof p e) = fsep $ map pretty p ++ [pretty e]

instance Pretty ProofCommand where

pretty = printProofCommand

printProofCommand :: ProofCommand -> Doc

printProofCommand pc =

case pc of

Apply pms plus ->

let plusDoc = if plus then text "+" else empty

in text applyS <+> parens

(sepByCommas $ map pretty pms) <> plusDoc

Using ls -> text usingS <+> fsep (map text ls)

Back -> text backS

Defer x -> text deferS <+> pretty x

Prefer x -> text preferS <+> pretty x

Refute -> text refuteS

instance Pretty ProofEnd where

pretty = printProofEnd

printProofEnd :: ProofEnd -> Doc

printProofEnd pe =

case pe of

By pm -> text byS <+> parens (pretty pm)

DotDot -> text dotDot

Done -> text doneS

Oops -> text oopsS

Sorry -> text sorryS

instance Pretty Modifier where

pretty = printModifier

printModifier :: Modifier -> Doc

printModifier m =

case m of

No_asm -> text "no_asm"

No_asm_simp -> text "no_asm_simp"

No_asm_use -> text "no_asm_use"

instance Pretty ProofMethod where

pretty = printProofMethod

printProofMethod :: ProofMethod -> Doc

printProofMethod pm =

case pm of

Auto -> text autoS

Simp -> text simpS

AutoSimpAdd m names -> let modDoc = case m of

Just mod' -> parens $ pretty mod'

Nothing -> empty

in fsep $ [text autoS, text simpS, modDoc,

text "add:"] ++ map text names

SimpAdd m names -> let modDoc = case m of

Just mod' -> parens $ pretty mod'

Nothing -> empty

in fsep $ [text simpS, modDoc, text "add:"] ++

map text names

Induct var -> text inductS <+> doubleQuotes (printTerm var)

CaseTac t -> text caseTacS <+> doubleQuotes (printTerm t)

SubgoalTac t -> text subgoalTacS <+> doubleQuotes (printTerm t)

Insert ts -> fsep (text insertS : map text ts)

Other s -> text s