module Language.CSPM.AstToProlog
(
toProlog
)
where
import Language.CSPM.Rename (ModuleFromRenaming)
import Language.CSPM.AST as AST
import Language.CSPM.CompileAstToProlog (mkSrcLoc)
import qualified Language.Prolog.PrettyPrint.Direct as Prolog (unTerm,atom,unAtom)
import Language.CSPM.SrcLoc as SrcLoc
import GHC.Generics as Generics
import Text.PrettyPrint
import Data.Array.IArray as Array
import qualified Data.IntMap as IntMap
toProlog :: TP d => d -> Doc
toProlog = tp
class GTP f where
gtp :: f a -> Doc
class GTPL f where
gtpl :: Doc -> f a -> Doc
class TP f where
tp :: f -> Doc
default tp :: (Generic f, GTP (Rep f)) => f -> Doc
tp = gtp . from
class TPL f where
tpl :: Doc -> f -> Doc
default tpl :: (Generic f, GTPL (Rep f)) => Doc -> f -> Doc
tpl l = gtpl l . from
instance TPL f => TP (Labeled f) where
tp a = tpl (tp $ srcLoc a) $ unLabel a
instance TPL Decl
instance TPL Ident where tpl l = tpl l . unUIdent
instance TPL Pattern
instance TPL Exp
instance TPL UniqueIdent where
tpl l ident = text "'UniqueIdent'" <> parens (l<> comma <> i)
where
i = case idType ident of
TransparentID -> atom $ realName ident
_ -> atom $ newName ident
instance TPL AssertDecl
instance TPL AST.Constructor
instance TPL TypeDef
instance TPL Range
instance TPL CompGen
instance TPL LinkList
instance TPL Rename
instance TPL Link
instance TPL BuiltIn
instance TPL CommField
instance TPL [Labeled CompGen] where tpl _ = tp
instance TPL RefineOp
instance TPL TauRefineOp
instance TPL FDRModels
instance TPL FdrExt
instance TP ModuleFromRenaming where
tp m = text "module" <> parens ( hcat $ punctuate comma [
tp $ moduleSrcLoc m
,tp $ moduleDecls m
,tp $ moduleComments m
,tp $ modulePragmas m
])
instance TP Comment
instance TP SrcLoc where tp = Prolog.unTerm . mkSrcLoc
instance TP [Char] where tp = atom
instance TP f => TP [f] where
tp l = brackets $ hcat $ punctuate comma $ map tp l
instance TP f => TP (Maybe f) where
tp Nothing = text "none"
tp (Just x) = tp x
instance (TP a, TP b) => TP (a,b) where
tp (a,b) = parens (tp a <> comma <> tp b)
instance TP Integer where tp = integer
instance TP Int where tp = integer . fromIntegral
instance TP e => TP (Array Int e) where tp = tp . Array.elems
instance TP e => TP (IntMap.IntMap e) where tp = tp . IntMap.elems
instance TP Bool
instance TP Const
instance TP FunCase
instance TP AST.Selector
instance TP UniqueIdent where tp = tpl (text "none")
instance (GTP a, GTP b) => GTP (a :*: b) where
gtp (a :*: b) = gtp a <+> comma <+> gtp b
instance (GTPL a, GTPL b) => GTPL (a :*: b) where
gtpl l (a :*: b) = gtpl l a <+> comma <+> gtpl l b
instance (GTP l, GTP r) => GTP (l :+: r) where
gtp (L1 l) = gtp l
gtp (R1 r) = gtp r
instance (GTPL l, GTPL r) => GTPL (l :+: r) where
gtpl s (L1 l) = gtpl s l
gtpl s (R1 r) = gtpl s r
instance (GTP t, Datatype r) => GTP (M1 D r t) where
gtp = gtp . unM1
instance (GTPL t, Datatype r) => GTPL (M1 D r t) where
gtpl l = gtpl l . unM1
instance (GTP t, Generics.Constructor c) => GTP (M1 C c t) where
gtp x = hcat [ atom $ conName x, lparen, gtp $ unM1 x, rparen]
instance (GTPL t, Generics.Constructor c) => GTPL (M1 C c t) where
gtpl l x = hcat [ atom $ conName x, lparen, l, comma, gtpl l $ unM1 x, rparen]
instance (GTP t, Generics.Selector c) => GTP (M1 S c t) where
gtp = gtp . unM1
instance (GTPL t, Generics.Selector c) => GTPL (M1 S c t) where
gtpl l = gtpl l . unM1
instance TP t => GTP (K1 R t) where
gtp x = tp $ unK1 x
instance TP t => GTPL (K1 R t) where
gtpl _l x = tp $ unK1 x
instance TP t => GTP (K1 P t) where
gtp x = hsep [ text "rec" , lparen, tp $ unK1 x, rparen]
instance TP t => GTPL (K1 P t) where
gtpl _ x = hsep [ text "rec" , lparen, tp $ unK1 x, rparen]
instance GTP V1 where gtp _ = text "V1"
instance GTPL V1 where gtpl _ _ = text "V1"
instance GTP U1 where gtp _ = text "U1"
instance GTPL U1 where gtpl _ _ = text "U1"
atom :: String -> Doc
atom = Prolog.unAtom . Prolog.atom