PrintAs.hs revision 966e627a1c06b302a06d59d08b8ab45905f3509c
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannModule : $Header$
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannCopyright : (c) Christian Maeder and Uni Bremen 2003
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannLicence : similar to LGPL, see HetCATS/LICENCE.txt or LIZENZ.txt
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannMaintainer : hets@tzi.de
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannStability : experimental
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannPortability : portable
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printing data types of the abstract syntax
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmannimport Common.GlobalAnnotations(GlobalAnnos)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | short cut for: if b then empty else d
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannnoPrint :: Bool -> Doc -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannnoPrint b d = if b then empty else d
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Variance where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ v = text $ show v
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Kind where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga knd = case knd of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Intersection [] _ -> text "Type"
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MissingKind -> space
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ClassKind ci _ -> printText0 ga ci
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Downset mt t _ _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann let tok = case mt of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Nothing -> text "_"
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Just x -> text (tokStr x) <+> text dotS <+> text (tokStr x)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann in braces (tok <+>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann text lessS <+> printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Intersection ks _ -> printList0 ga ks
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunKind k1 k2 _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunKind _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) (printText0 ga k1)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text funS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga k2
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ExtKind k v _ -> (case k of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunKind _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) (printText0 ga k) <> printText0 ga v
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint TypePattern where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga tp = case tp of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypePattern name args _ -> printText0 ga name
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <> fcat (map (parens . printText0 ga) args)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypePatternToken t -> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixfixTypePattern ts -> fsep (map (printText0 ga) ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketTypePattern k l _ -> bracket k $ commaT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypePatternArg t _ -> parens $ printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | put proper brackets around a document
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmannbracket :: BracketKind -> Doc -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmannbracket b t = let (o,c) = getBrackets b in text o <> t <> text c
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | print a 'Kind' plus a preceding colon (or nothing for 'star')
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintKind :: GlobalAnnos -> Kind -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintKind ga kind = case kind of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Intersection [] _ -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Downset Nothing t _ _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann space <> text lessS <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> space <> colon <+> printText0 ga kind
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Type where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga ty = case ty of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeName name _k i -> printText0 ga name <>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann if i == 0 then empty else text ("_v"++ show i)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeAppl t1 t2 -> case t1 of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeName (Id [a, Token "__" _, b] [] []) _ _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga a <> printText0 ga t2 <> printText0 ga b
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeAppl (TypeName (Id [Token "__" _, inTok, Token "__" _]
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann [] []) _ _) t0 -> printText0 ga t0
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga inTok <+> printText0 ga t2
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> (case t1 of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeName _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeToken _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketType _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeAppl _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> parens) (printText0 ga t1) <+>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeName _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeToken _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketType _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> parens) (printText0 ga t2)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ExpandedType t1 t2 -> printText0 ga t1 <> (case t2 of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType [] _ -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> text asP <> parens (printText0 ga t2))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeToken t -> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketType k l _ -> bracket k $ commaT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann KindedType t kind _ -> (case t of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType _ _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType [] _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann LazyType _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeAppl _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) (printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> colon <+> printText0 ga kind
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixfixType ts -> fsep (map (printText0 ga) ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann LazyType t _ -> text quMark <+> (case t of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType _ _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType [] _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann KindedType _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) (printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType ts _ -> if null ts then text "Unit"
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann -- parens empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann else fsep (punctuate (space <> char '*')
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (map ( \ t ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType _ _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType [] _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProductType _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) $ printText0 ga t) ts))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType t1 arr t2 _ -> (case t1 of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType _ _ _ _ -> parens
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> id) (printText0 ga t1)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga arr
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga t2
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- no curried notation for bound variables
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint TypeScheme where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (TypeScheme vs t _) = let tdoc = printText0 ga t in
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann if null vs then tdoc else
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann hang (text forallS <+> semiT_text ga vs <+> text dotS) 2 tdoc
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Instance where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ i = case i of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Instance -> space <> text instanceS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Plain -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Partiality where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ p = case p of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Partial -> text quMark
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Total -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Arrow where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ a = text $ show a
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Quantifier where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ q = text $ show q
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint TypeQual where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ q = text $ show q
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Term where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga t = printTerm ga
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann QualVar _ -> True
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann QualOp _ _ _ _ -> True
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> False) t
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannunPredType :: Type -> Type
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannunPredType t = case t of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FunType ty PFunArr (TypeName
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (Id [Token "Unit" _] [] _)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (Intersection [] _) 0) _ -> ty
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannunPredTypeScheme :: TypeScheme -> TypeScheme
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannunPredTypeScheme = mapTypeOfScheme unPredType
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintTerm :: GlobalAnnos -> Bool -> Term -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintTerm ga b trm =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann let ppParen = if b then parens else id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann commaT = fsep . punctuate comma . map (printTerm ga False)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TupleTerm _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketTerm _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TermToken _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixTypeTerm _ _ _ -> id
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> ppParen)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann $ case trm of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann QualVar vd -> text varS <+> printText0 ga vd
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann QualOp br n t _ -> sep [printText0 ga br <+> printText0 ga n,
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann colon <+> printText0 ga
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (if isPred br then unPredTypeScheme t else t)]
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ResolvedMixTerm n ts _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann [] -> printText0 ga n
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann [t] -> printText0 ga n <> printTerm ga True t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> printText0 ga n <> parens (commaT ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ApplTerm t1 t2 _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann cat [printText0 ga t1, nest 2 $ printTerm ga True t2]
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TupleTerm ts _ -> parens (commaT ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypedTerm term q typ _ -> hang (printText0 ga term <+> printText0 ga q)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 4 $ printText0 ga typ
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann QuantifiedTerm q vs t _ -> hang (printText0 ga q <+> semiT_text ga vs)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 2 (text dotS <+> printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann LambdaTerm ps q t _ -> hang (text lamS <+> (case ps of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann [p] -> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> fcat $ map (parens . printTerm ga False) ps))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 2 ((case q of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Partial -> text dotS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Total -> text $ dotS ++ exMark) <+> printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann CaseTerm t es _ -> hang (text caseS <+> printText0 ga t <+> text ofS)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 4 $ vcat (punctuate (text " | ") $ map (printEq0 ga funS) es)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann LetTerm br es t _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann let dt = printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann des = vcat $ punctuate semi $ map (printEq0 ga equalS) es
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann in case br of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Let -> sep [text letS <+> des, text inS <+> dt]
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Where -> hang (sep [dt, text whereS]) 6 des
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Program -> text programS <+> des
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TermToken t -> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixTypeTerm q t _ -> printText0 ga q <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixfixTerm ts -> fsep $ map (printText0 ga) ts
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BracketTerm k l _ -> bracket k $ commaT l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann AsPattern v p _ -> printText0 ga v <+> text asP <+> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | print an equation with different symbols between 'Pattern' and 'Term'
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintEq0 :: GlobalAnnos -> String -> ProgEq -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintEq0 ga s (ProgEq p t _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann hang (hang (printText0 ga p) 2 $ text s) 4 $ printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint VarDecl where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (VarDecl v t _ _) = printText0 ga v <>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann MixfixType [] -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> space <> colon <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint GenVarDecl where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga gvd = case gvd of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann GenVarDecl v -> printText0 ga v
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann GenTypeVarDecl tv -> printText0 ga tv
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint TypeArg where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (TypeArg v c _ _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga v <+> colon <+> printText0 ga c
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | don't print an empty list and put parens around longer lists
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintList0 :: (PrettyPrint a) => GlobalAnnos -> [a] -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintList0 ga l = case l of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann [x] -> printText0 ga x
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> parens $ commaT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint InstOpId where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (InstOpId n l _) = printText0 ga n <> noPrint (null l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (brackets $ semiT_text ga l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann------------------------------------------------------------------------
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann------------------------------------------------------------------------
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | print a 'TypeScheme' as a pseudo type
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintPseudoType :: GlobalAnnos -> TypeScheme -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintPseudoType ga (TypeScheme l t _) = noPrint (null l) (text lamS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> (if null $ tail l then printText0 ga $ head l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann else fcat(map (parens . printText0 ga) l))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text dotS <> space) <> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint BasicSpec where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (BasicSpec l) = vcat (map (printText0 ga) l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint ProgEq where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga = printEq0 ga equalS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint BasicItem where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga bi = case bi of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann SigItems s -> printText0 ga s
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ProgItems l _ -> noPrint (null l) $ text programS <+> semiT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann ClassItems i l _ -> noPrint (null l) $ text classS <> printText0 ga i
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> semiT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann GenVarItems l _ -> noPrint (null l) $ text varS <+> semiT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann FreeDatatype l _ -> noPrint (null l) $ text freeS <+> text typeS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> semiT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann GenItems l _ -> noPrint (null l) $ text generatedS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> braces (semiT_text ga l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann AxiomItems vs fs _ -> (noPrint (null vs) $ text forallS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> semiT_text ga vs)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann $$ vcat (map ( \ x -> text dotS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga x) fs)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Internal l _ -> noPrint (null l) $ text internalS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> braces (semiT_text ga l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint OpBrand where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ b = text $ show b
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint SigItems where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga si = case si of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeItems i l _ -> noPrint (null l) $ text typeS <> printText0 ga i
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> semiT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann OpItems b l _ -> noPrint (null l) $ printText0 ga b <+> semiT_text ga
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (if isPred b then concat $
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann mapAnM ((:[]) . mapOpItem) l else l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint ClassItem where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (ClassItem d l _) = printText0 ga d $$
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann if null l then empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann else braces (semiT_text ga l)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint ClassDecl where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (ClassDecl l k _) = commaT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text lessS <+> printText0 ga k
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Vars where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga vd = case vd of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Var v -> printText0 ga v
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann VarTuple vs _ -> parens $ commaT_text ga vs
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint TypeItem where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga ti = case ti of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann TypeDecl l k _ -> if null l then error "printText0 TypeDecl" else
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann commaT_text ga l <> printKind ga k
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann SubtypeDecl l t _ -> if null l then error "printText0 SubtypeDecl"
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann else commaT_text ga l <+> text lessS <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann IsoDecl l _ -> cat(punctuate (text " = ")
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (map (printText0 ga) l))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann SubtypeDefn p v t f _ -> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text equalS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> braces (printText0 ga v
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text dotS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga f)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann AliasType p k t _ -> (printText0 ga p <>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Nothing -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Just j -> space <> colon <+>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga j)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text assignS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printPseudoType ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Datatype t -> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannmapOpItem :: OpItem -> OpItem
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannmapOpItem oi = case oi of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann OpDecl l t as ps -> OpDecl l (unPredTypeScheme t) as ps
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann OpDefn n ps s p t qs -> OpDefn n ps (unPredTypeScheme s) p t qs
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint OpItem where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga oi = case oi of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann OpDecl l t attrs _ -> if null l then error "printText0 OpDecl" else
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann commaT_text ga l <+> colon <+> (printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <> (if null attrs then empty else comma <> space)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <> commaT_text ga attrs)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann OpDefn n ps s p t _ -> hang
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (hang (printText0 ga n <> fcat (map (parens . semiT_text ga) ps))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 2 (colon <> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga s))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann 2 (text equalS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint BinOpAttr where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 _ a = text $ case a of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Assoc -> assocS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Comm -> commS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Idem -> idemS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint OpAttr where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga oa = case oa of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann BinOpAttr a _ -> printText0 ga a
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann UnitOpAttr t _ -> text unitS <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint DatatypeDecl where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (DatatypeDecl p k alts d _) = (printText0 ga p <>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printKind ga k)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> text defnS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> vcat(punctuate (text " | ")
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (map (printText0 ga) alts))
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> case d of [] -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> text derivingS
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> commaT_text ga d
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Alternative where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga alt = case alt of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Constructor n cs p _ ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga n <+> fsep (map (parens . semiT_text ga) cs)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Subtype l _ -> noPrint (null l) $ text typeS <+> commaT_text ga l
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Component where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga sel = case sel of
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Selector n p t _ _ -> printText0 ga n
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> colon <> printText0 ga p
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann NoSelector t -> printText0 ga t
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint OpId where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (OpId n ts _) = printText0 ga n
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann <+> noPrint (null ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann (brackets $ commaT_text ga ts)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint Symb where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (Symb i mt _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga i <> (case mt of Nothing -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann Just (SymbType t) ->
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann empty <+> colon <+>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint SymbItems where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (SymbItems k syms _ _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printSK k <> commaT_text ga syms
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint SymbOrMap where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (SymbOrMap s mt _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga s <> (case mt of Nothing -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann empty <+> text mapsTo <+>
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga t)
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmanninstance PrettyPrint SymbMapItems where
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printText0 ga (SymbMapItems k syms _ _) =
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann printSK k <> commaT_text ga syms
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann-- | print symbol kind
304d15b2ffa9376d78bddcfc63569824381714abDaniel HausmannprintSK :: SymbKind -> Doc
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann case k of Implicit -> empty
304d15b2ffa9376d78bddcfc63569824381714abDaniel Hausmann _ -> text (drop 3 $ show k) <> space