Print_AS_Structured.hs revision b25c72845890740c2f8a21214752574990b943cf
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu{- |
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuModule : $Header$
734257b9ea9fcaa18d4e3627f54f5295a99aa1f7Felix Gabriel ManceDescription : pretty printing of CASL structured specifications
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuCopyright : (c) Klaus Luettich, Uni Bremen 2002-2006
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuLicense : GPLv2 or higher, see LICENSE.txt
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuMaintainer : Christian.Maeder@dfki.de
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuStability : provisional
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae BungiuPortability : non-portable(Grothendieck)
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu
c038fcf2030a6cfac7a261dee48a9eb29edb78eaFelix Gabriel MancePretty printing of CASL structured specifications
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu-}
15d62726781e67fe6458fbcf0a8c46832a7bb8daFelix Gabriel Mance
734257b9ea9fcaa18d4e3627f54f5295a99aa1f7Felix Gabriel Mancemodule Syntax.Print_AS_Structured
c038fcf2030a6cfac7a261dee48a9eb29edb78eaFelix Gabriel Mance ( structSimpleId
c038fcf2030a6cfac7a261dee48a9eb29edb78eaFelix Gabriel Mance , printGroupSpec
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu , skipVoidGroup
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu , printUnion
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu , printExtension
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiu , moveAnnos
ed1b8e97e72b2e3e92edaf2eb22a4b5373d705f1Felix Gabriel Mance ) where
5180a08007989fd364622fc9bc01f82141643f7bFelix Gabriel Mance
ccb84c1cb43fb0ed70c5bf2d364e671820473ed5Francisc Nicolae Bungiuimport Common.Id
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Manceimport Common.Keywords
734257b9ea9fcaa18d4e3627f54f5295a99aa1f7Felix Gabriel Manceimport Common.Doc
c038fcf2030a6cfac7a261dee48a9eb29edb78eaFelix Gabriel Manceimport Common.DocUtils
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Manceimport Common.AS_Annotation
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Mance
3b15ba1ffa9a23ca14f3882d1390abddfc494009Felix Gabriel Manceimport Logic.Grothendieck ()
3b15ba1ffa9a23ca14f3882d1390abddfc494009Felix Gabriel Mance
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Manceimport Syntax.AS_Structured
e5dc5119231bdeb5c604f7709e0fa197fd2c4829Felix Gabriel Mance
e5dc5119231bdeb5c604f7709e0fa197fd2c4829Felix Gabriel MancestructSimpleId :: SIMPLE_ID -> Doc
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel MancestructSimpleId = structId . tokStr
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Mance
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Manceinstance Pretty SPEC where
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance pretty = printSPEC
e5dc5119231bdeb5c604f7709e0fa197fd2c4829Felix Gabriel Mance
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel ManceprintUnion :: [Annoted SPEC] -> [Doc]
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel ManceprintUnion = prepPunctuate (topKey andS <> space) . map condBracesAnd
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel MancemoveAnnos :: Annoted SPEC -> [Annoted SPEC] -> [Annoted SPEC]
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel MancemoveAnnos x l = appAnno $ case l of
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance [] -> error "moveAnnos"
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance h : r -> h { l_annos = l_annos x ++ l_annos h } : r
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance where appAnno a = case a of
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance [] -> []
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance [h] -> [appendAnno h (r_annos x)]
2c0c0264249b8d2a3f465e22cb3c6d9c4ac8924aFelix Gabriel Mance h : r -> h : appAnno r
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel ManceprintOptUnion :: Annoted SPEC -> [Doc]
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel ManceprintOptUnion x = case skipVoidGroup $ item x of
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance Union e@(_ : _) _ -> printUnion $ moveAnnos x e
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance Extension e@(_ : _) _ -> printExtension $ moveAnnos x e
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance _ -> [pretty x]
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel ManceprintExtension :: [Annoted SPEC] -> [Doc]
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel ManceprintExtension l = case l of
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance [] -> []
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance x : r -> printOptUnion x ++
120b4b5a0f61d93eeaa17ff2c7867f58c7325e3bFelix Gabriel Mance concatMap (( \ u -> case u of
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance [] -> []
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance d : s -> (topKey thenS <+> d) : s) .
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance printOptUnion) r
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel ManceprintSPEC :: SPEC -> Doc
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel ManceprintSPEC spec = case spec of
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance Basic_spec aa _ -> pretty aa
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Mance EmptySpec _ -> specBraces empty
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance Translation aa ab -> sep [condBracesTransReduct aa, printRENAMING ab]
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance Reduction aa ab -> sep [condBracesTransReduct aa, printRESTRICTION ab]
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel Mance Union aa _ -> sep $ printUnion aa
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance Extension aa _ -> sep $ printExtension aa
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance Free_spec aa _ -> sep [keyword freeS, printGroupSpec aa]
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance Cofree_spec aa _ -> sep [keyword cofreeS, printGroupSpec aa]
9c3f6477a95da46a907326206673b4a5c2164164Felix Gabriel Mance Local_spec aa ab _ -> fsep
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance [keyword localS, pretty aa, keyword withinS, condBracesWithin ab]
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance Closed_spec aa _ -> sep [keyword closedS, printGroupSpec aa]
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance Group aa _ -> pretty aa
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance Spec_inst aa ab _ -> cat [structSimpleId aa, print_fit_arg_list ab]
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance Qualified_spec ln asp _ -> printLogicEncoding ln <> colon $+$ pretty asp
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance Data _ _ s1 s2 _ -> keyword dataS <+> printGroupSpec s1 $+$ pretty s2
9c3f6477a95da46a907326206673b4a5c2164164Felix Gabriel Mance
316ef492799cd45fea0f5c26932f49adddfda3f7Felix Gabriel Manceinstance Pretty RENAMING where
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel Mance pretty = printRENAMING
31a5ba51cd6d24e28a23abf64ce4043a45eabbefFelix Gabriel Mance
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel ManceprintRENAMING :: RENAMING -> Doc
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel ManceprintRENAMING (Renaming aa _) =
316ef492799cd45fea0f5c26932f49adddfda3f7Felix Gabriel Mance keyword withS <+> ppWithCommas aa
316ef492799cd45fea0f5c26932f49adddfda3f7Felix Gabriel Mance
316ef492799cd45fea0f5c26932f49adddfda3f7Felix Gabriel Manceinstance Pretty RESTRICTION where
316ef492799cd45fea0f5c26932f49adddfda3f7Felix Gabriel Mance pretty = printRESTRICTION
31a5ba51cd6d24e28a23abf64ce4043a45eabbefFelix Gabriel Mance
0be7a9c012366ada63d587898a15c551b499b76dFelix Gabriel ManceprintRESTRICTION :: RESTRICTION -> Doc
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel ManceprintRESTRICTION rest = case rest of
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Mance Hidden aa _ -> keyword hideS <+> ppWithCommas aa
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Mance Revealed aa _ -> keyword revealS <+> pretty aa
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Mance
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel ManceprintLogicEncoding :: (Pretty a) => a -> Doc
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel ManceprintLogicEncoding enc = keyword logicS <+> pretty enc
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Mance
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Manceinstance Pretty G_mapping where
734257b9ea9fcaa18d4e3627f54f5295a99aa1f7Felix Gabriel Mance pretty = printG_mapping
31a5ba51cd6d24e28a23abf64ce4043a45eabbefFelix Gabriel Mance
3e0eb79b52a3078a12531efc3f66d0d94fd9938dFelix Gabriel ManceprintG_mapping :: G_mapping -> Doc
e5ea4eeaeefd3521ae3475719e18c96cf91637d5Felix Gabriel ManceprintG_mapping gma = case gma of
15d62726781e67fe6458fbcf0a8c46832a7bb8daFelix Gabriel Mance G_symb_map gsmil -> pretty gsmil
15d62726781e67fe6458fbcf0a8c46832a7bb8daFelix Gabriel Mance G_logic_translation enc -> printLogicEncoding enc
e5e3f128bbd44dd393e1038718038bd323f5e415Felix Gabriel Mance
dda7065c0c0f383558d7d4e8072969c8c41a8ed7Francisc Nicolae Bungiuinstance Pretty G_hiding where
15d62726781e67fe6458fbcf0a8c46832a7bb8daFelix Gabriel Mance pretty = printG_hiding
e5ea4eeaeefd3521ae3475719e18c96cf91637d5Felix Gabriel Mance
e5ea4eeaeefd3521ae3475719e18c96cf91637d5Felix Gabriel ManceprintG_hiding :: G_hiding -> Doc
dda7065c0c0f383558d7d4e8072969c8c41a8ed7Francisc Nicolae BungiuprintG_hiding ghid = case ghid of
734257b9ea9fcaa18d4e3627f54f5295a99aa1f7Felix Gabriel Mance G_symb_list gsil -> pretty gsil
c4076ff1721f8901a30e4b7aa004479ecb2631e0Felix Gabriel Mance G_logic_projection enc -> printLogicEncoding enc
30e9cf458094e5970bc06be667558961c2eccff4Felix Gabriel Mance
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Manceinstance Pretty FIT_ARG where
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance pretty = printFIT_ARG
12078a24d49ba36b83cda9d07c8e8a480c493fe8Felix Gabriel Mance
printFIT_ARG :: FIT_ARG -> Doc
printFIT_ARG fit = case fit of
Fit_spec aa ab _ ->
let aa' = rmTopKey $ pretty aa
in if null ab then aa' else
fsep $ aa' : keyword fitS
: punctuate comma (map printG_mapping ab)
Fit_view si ab _ ->
sep [keyword viewS, cat [structSimpleId si, print_fit_arg_list ab]]
instance Pretty Logic_code where
pretty = printLogic_code
printLogic_code :: Logic_code -> Doc
printLogic_code (Logic_code menc msrc mtar _) =
let pm = maybe [] ((: []) . printLogic_name) in
fsep $ maybe [] ((: [colon]) . pretty) menc
++ pm msrc ++ funArrow : pm mtar
instance Pretty Logic_name where
pretty = printLogic_name
printLogic_name :: Logic_name -> Doc
printLogic_name (Logic_name mlog slog) = let d = structSimpleId mlog in
case slog of
Nothing -> d
Just sub -> d <> dot <> structSimpleId sub
{- |
specialized printing of 'FIT_ARG's
-}
print_fit_arg_list :: [Annoted FIT_ARG] -> Doc
print_fit_arg_list = cat . map (brackets . pretty)
{- |
conditional generation of grouping braces for Union and Extension
-}
printGroupSpec :: Annoted SPEC -> Doc
printGroupSpec s = let d = pretty s in
case skip_Group $ item s of
Spec_inst _ _ _ -> d
_ -> specBraces d
{- |
generate grouping braces for Tanslations and Reductions
-}
condBracesTransReduct :: Annoted SPEC -> Doc
condBracesTransReduct s = let d = pretty s in
case skip_Group $ item s of
Extension _ _ -> specBraces d
Union _ _ -> specBraces d
Local_spec _ _ _ -> specBraces d
_ -> d
{- |
generate grouping braces for Within
-}
condBracesWithin :: Annoted SPEC -> Doc
condBracesWithin s = let d = pretty s in
case skip_Group $ item s of
Extension _ _ -> specBraces d
Union _ _ -> specBraces d
_ -> d
{- |
only Extensions inside of Unions (and) need grouping braces
-}
condBracesAnd :: Annoted SPEC -> Doc
condBracesAnd s = let d = pretty s in
case skip_Group $ item s of
Extension _ _ -> specBraces d
_ -> d
-- | only skip groups without annotations
skipVoidGroup :: SPEC -> SPEC
skipVoidGroup sp =
case sp of
Group g _ | null (l_annos g) && null (r_annos g)
-> skipVoidGroup $ item g
_ -> sp
-- | skip nested groups
skip_Group :: SPEC -> SPEC
skip_Group sp =
case sp of
Group g _ -> skip_Group $ item g
_ -> sp