module DatabaseDesign.Ampersand.Fspec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier)
where
import DatabaseDesign.Ampersand.Core.ParseTree
import DatabaseDesign.Ampersand.Core.AbstractSyntaxTree
import Text.Pandoc hiding (Meta)
import Data.Char (isAlphaNum)
import DatabaseDesign.Ampersand.Basics
import DatabaseDesign.Ampersand.Fspec.Plug
import DatabaseDesign.Ampersand.Fspec.Fspec
import DatabaseDesign.Ampersand.Fspec.ShowADL (ShowADL(..))
import Data.List
import DatabaseDesign.Ampersand.Classes
import qualified DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner
import DatabaseDesign.Ampersand.Misc
import Data.Hashable
import Data.Ord
import Data.Function
fatal :: Int -> String -> a
fatal = fatalMsg "Fspec.ShowHS"
fSpec2Haskell :: Fspc -> Options -> String
fSpec2Haskell fSpec flags
= "{-# OPTIONS_GHC -Wall #-}"
++"\n{-Generated code by "++ampersandVersionStr++" at "++show (genTime flags)++"-}"
++"\nmodule Main where"
++"\n import DatabaseDesign.Ampersand"
++"\n import Text.Pandoc hiding (Meta)"
++"\n import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)"
++"\n"
++"\n main :: IO ()"
++"\n main = do flags <- getOptions"
++"\n putStr (showHS flags \"\\n \" fSpec_"++baseName flags++")"
++"\n fSpec_"++baseName flags++" :: Fspc"
++"\n fSpec_"++baseName flags++"\n = "++showHS flags "\n " fSpec
wrap :: String->String->(String->a->String)->[a]->String
wrap initStr indent f xs
= initStr++
case xs of
[] -> "[]"
[x] -> "[ "++f (indent++" ") x++" ]"
_ -> "[ "++intercalate (indent++", ") [f (indent++" ") x | x<-xs]++indent++"]"
class ShowHSName a where
showHSName :: a -> String
class ShowHS a where
showHS :: Options -> String -> a -> String
instance ShowHSName a => ShowHSName [a] where
showHSName xs = "["++intercalate "," (map showHSName xs)++"]"
instance ShowHS a => ShowHS [a] where
showHS flags indent = wrap "" (indent++" ") (showHS flags)
instance ShowHSName a => ShowHSName (Maybe a) where
showHSName Nothing = "Nothing"
showHSName (Just x) = showHSName x
instance ShowHS a => ShowHS (Maybe a) where
showHS _ _ Nothing = "Nothing"
showHS flags indent (Just x) = "Just (" ++ showHS flags indent x ++ ")"
instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where
showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )"
instance ShowHSName PlugSQL where
showHSName plug = haskellIdentifier ("plug_"++name plug)
instance ShowHS PlugSQL where
showHS flags indent plug
= case plug of
TblSQL{} -> intercalate indent
["let " ++ intercalate (indent++" ")
[showHSName f++indent++" = "++showHS flags (indent++" ") f | f<-fields plug] ++indent++"in"
,"TblSQL { sqlname = " ++ (show.name) plug
," , fields = ["++intercalate ", " (map showHSName (fields plug))++"]"
," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"
," , mLkpTbl = [ "++intercalate (indent++" , ") ["("++showHS flags "" r++", "++showHSName ms++", "++showHSName mt++")" | (r,ms,mt)<-mLkpTbl plug] ++ "]"
," }"
]
BinSQL{} -> intercalate indent
["let " ++ showHSName (fst (columns plug))++indent++" = "++showHS flags (indent++" ") (fst (columns plug))
++ (indent++" ") ++ showHSName (snd (columns plug))++indent++" = "++showHS flags (indent++" ") (snd (columns plug))
++indent++"in"
,"BinSQL { sqlname = " ++ (show.name) plug
," , columns = ("++showHSName (fst (columns plug))++ ", " ++showHSName (snd (columns plug))++")"
," , cLkpTbl = [ "++intercalate (indent++" , ") ["("++showHSName c++", "++showHSName cn++")" | (c,cn)<-cLkpTbl plug] ++ "]"
," , mLkp = "++showHS flags "" (mLkp plug)
," }"
]
ScalarSQL{} -> intercalate indent
["ScalarSQL { sqlname = "++ (show.name) plug
," , sqlColumn = "++ showHS flags (indent++" ") (sqlColumn plug)
," , cLkp = "++ showHSName (cLkp plug)
," }"
]
instance ShowHSName (ECArule) where
showHSName r = "ecaRule"++show (ecaNum r)
instance ShowHS (ECArule) where
showHS flags indent r
= "ECA { ecaTriggr = " ++ showHS flags "" (ecaTriggr r) ++
indent++" , ecaDelta = " ++ showHS flags (indent++" ") (ecaDelta r)++
indent++" , ecaAction = " ++ showHS flags (indent++" ") (ecaAction r)++
indent++" , ecaNum = " ++ show (ecaNum r)++
indent++" }"
instance ShowHS Event where
showHS _ indent e
= if "\n" `isPrefixOf` indent
then "On " ++ show (eSrt e)++indent++" " ++ showHSName (eDcl e)++indent++" "
else "On " ++ show (eSrt e)++ " " ++ showHSName (eDcl e)++ ""
instance ShowHS (InsDel, Expression, PAclause) where
showHS flags indent (tOp, links, p)
= "( "++show tOp++indent++", "++showHS flags (indent++" ") links++indent++", "++showHS flags (indent++" ") p++indent++")"
instance ShowHS PAclause where
showHS flags indent p
= case p of
CHC{} -> wrap "CHC " (indent ++" ") (showHS flags) (paCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
GCH{} -> wrap "GCH " (indent ++" ") (showHS flags) (paGCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
ALL{} -> wrap "ALL " (indent ++" ") (showHS flags) (paCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Do{} -> "Do "++show (paSrt p)++ " ("++showHS flags (indent++" ") (paTo p)++indent++" )"++
indent++" ("++showHS flags (indent++" ") (paDelta p)++indent++" )"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
New{} -> "New ("++showHS flags "" (paCpt p)++")"++
indent++" (\\x->"++showHS flags (indent++" ") (paCl p "x")++indent++" )"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Rmv{} -> "Rmv ("++showHS flags "" (paCpt p)++")"++
indent++" (\\x->"++showHS flags (indent++" ") (paCl p "x")++indent++" )"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Nop{} -> "Nop "++wrap "" (indent ++" ") showMotiv ms
Blk{} -> "Blk "++wrap "" (indent ++" ") showMotiv ms
Let{} -> wrap "Let " (indent ++" ") (showHS flags) (paCls p)++
"TODO: paBody of Let clause"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Ref{} -> "Ref "++paVar p
where ms = paMotiv p
showMotiv ind (conj,rs) = "( "++showHS flags (ind++" ") conj++" -- conjunct: "++showADL conj++ind++", "++showHSName rs++ind++")"
instance ShowHSName SqlField where
showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)
instance ShowHS SqlField where
showHS flags indent sqFd
= intercalate indentA
[ "Fld { fldname = " ++ show (fldname sqFd)
, ", fldexpr = " ++ showHS flags indentB (fldexpr sqFd)
, ", fldtype = " ++ showHS flags "" (fldtype sqFd)
, ", flduse = " ++ showHS flags "" (flduse sqFd)
, ", fldnull = " ++ show (fldnull sqFd)
, ", flduniq = " ++ show (flduniq sqFd)
, "}"
] where indentA = indent ++" "
indentB = indentA++" "
instance ShowHS SqlFieldUsage where
showHS _ _ (TableKey isPrimary aCpt) = "TableKey " ++show isPrimary++" "++showHSName aCpt
showHS _ _ (ForeignKey aCpt) = "ForeignKey "++showHSName aCpt
showHS _ _ PlainAttr = "PlainAttr "
instance ShowHS SqlType where
showHS _ indent (SQLChar i) = indent++"SQLChar "++show i
showHS _ indent SQLBlob = indent++"SQLBlob "
showHS _ indent SQLPass = indent++"SQLPass "
showHS _ indent SQLSingle = indent++"SQLSingle "
showHS _ indent SQLDouble = indent++"SQLDouble "
showHS _ indent SQLText = indent++"SQLText "
showHS _ indent (SQLuInt i) = indent++"SQLuInt "++show i
showHS _ indent (SQLsInt i) = indent++"SQLsInt "++show i
showHS _ indent SQLId = indent++"SQLId "
showHS _ indent (SQLVarchar i) = indent++"SQLVarchar "++show i
showHS _ indent SQLBool = indent++"SQLBool "
instance ShowHSName Quad where
showHSName q
= haskellIdentifier ("quad_"++(showHSName.qDcl) q++"_"++(name.cl_rule.qClauses) q)
instance ShowHS Quad where
showHS flags indent q
= intercalate indent
[ "Quad{ qDcl = " ++ showHSName (qDcl q)
, " , qClauses = " ++ showHS flags newindent (qClauses q)
, " }"
]
where
newindent = indent ++ " "
instance ShowHS Fswitchboard where
showHS flags indent fsb
= intercalate indent
[ "Fswtch { fsbEvIn = " ++ showHS flags newindent (fsbEvIn fsb)
, " , fsbEvOut = " ++ showHS flags newindent (fsbEvOut fsb)
,wrap
" , fsbConjs = " newindent' (\_->shConj) (fsbConjs fsb)
,wrap
" , fsbECAs = " newindent' (\_->showHSName) (fsbECAs fsb)
, " }"
]
where
newindent = indent ++ " "
newindent' = newindent ++ " "
newindent'' = newindent' ++ " "
shConj (r,conj) = "( "++showHSName r++newindent++" , "++showHS flags newindent'' conj++newindent++" )"
instance ShowHS Clauses where
showHS _ indent c
= intercalate indent
[ "Clauses{ cl_conjNF = " ++ showHSName (cl_conjNF c)
, " , cl_rule = " ++ showHSName (cl_rule c)
, " }"
]
instance ShowHS DnfClause where
showHS flags indent (Dnf antcs conss)
= intercalate indent
[ wrap "Dnf " (indent++" ") (\_->showHS flags (indent++" ")) antcs
, wrap " " (indent++" ") (\_->showHS flags (indent++" ")) conss
]
instance ShowHSName RuleClause where
showHSName x = haskellIdentifier ("conj_"++rc_rulename x++"["++show (rc_int x)++"]")
instance ShowHS RuleClause where
showHS flags indent x
= intercalate (indent ++" ")
[ "RC{ rc_int = " ++ show (rc_int x)
, ", rc_rulename = " ++ show (rc_rulename x)
, ", rc_conjunct = " ++ showHS flags indentA (rc_conjunct x)
,wrap ", rc_dnfClauses = " indentA (\_->showHS flags (indentA++" ")) (rc_dnfClauses x)
, "}"
]
where indentA = indent ++" "
instance ShowHSName Fspc where
showHSName fSpec = haskellIdentifier ("fSpc_"++name fSpec)
instance ShowHS Fspc where
showHS flags indent fSpec
= intercalate (indent ++" ")
[ "Fspc{ fsName = " ++ show (name fSpec)
,wrap ", fspos = " indentA (showHS flags) (fspos fSpec)
, ", fsLang = " ++ show (fsLang fSpec) ++ " -- the default language for this specification"
, ", themes = " ++ show (themes fSpec) ++ " -- the names of themes to be printed in the documentation, meant for partial documentation. Print all if empty..."
,wrap ", pattsInScope = " indentA (\_->showHSName) (pattsInScope fSpec)
,wrap ", procsInScope = " indentA (\_->showHSName) (procsInScope fSpec)
,wrap ", rulesInScope = " indentA (\_->showHSName) (rulesInScope fSpec)
,wrap ", declsInScope = " indentA (\_->showHSName) (declsInScope fSpec)
,wrap ", cDefsInScope = " indentA (\_->showHS flags (indentA++" ")) (cDefsInScope fSpec)
,wrap ", gensInScope = " indentA (showHS flags) (gensInScope fSpec)
,wrap ", vprocesses = " indentA (\_->showHSName) (vprocesses fSpec)
,wrap ", vplugInfos = " indentA (\_->showHS flags (indentA++" ")) (vplugInfos fSpec)
,wrap ", plugInfos = " indentA (\_->showHS flags (indentA++" ")) (plugInfos fSpec)
, ", interfaceS = interfaceS'"
, ", interfaceG = interfaceG'"
,wrap ", fActivities = " indentA (\_->showHS flags (indentA++" ")) (fActivities fSpec)
, ", fRoleRels = " ++
case fRoleRels fSpec of
[] -> "[]"
[(r,rel)] -> "[ ("++show r++", "++showHS flags "" rel++") ]"
_ -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHS flags "" rel++")" | (r,rel)<-fRoleRels fSpec]++indentA++"]"
, ", fRoleRuls = " ++
case fRoleRuls fSpec of
[] -> "[]"
[(r,rul)] -> "[ ("++show r++", "++showHSName rul++") ]"
_ -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHSName rul++")" | (r,rul)<-fRoleRuls fSpec]++indentA++"]"
,wrap ", fRoles = " indentA (\_->id) (fRoles fSpec)
,wrap ", vrules = " indentA (\_->showHSName) (vrules fSpec)
,wrap ", grules = " indentA (\_->showHSName) (grules fSpec)
,wrap ", invars = " indentA (\_->showHSName) (invars fSpec)
,wrap ", allRules = " indentA (\_->showHSName) (allRules fSpec)
,wrap ", allUsedDecls = " indentA (\_->showHSName) (allUsedDecls fSpec)
,wrap ", allDecls = " indentA (\_->showHSName) (allDecls fSpec)
,wrap ", vrels = " indentA (\_->showHSName) (vrels fSpec)
,wrap ", allConcepts = " indentA (\_->showHSName) (allConcepts fSpec)
,wrap ", kernels = " indentA (\_->showHSName) (kernels fSpec)
,wrap ", vIndices = " indentA (\_->showHSName) (vIndices fSpec)
,wrap ", vviews = " indentA (\_->showHSName) (vviews fSpec)
,wrap ", vgens = " indentA (showHS flags) (vgens fSpec)
,wrap ", fsisa = " indentA (\_->showHSName) (fsisa fSpec)
,wrap ", vconjs = " indentA (\_->showHSName) (vconjs fSpec)
,wrap ", vquads = " indentA (\_->showHSName) (vquads fSpec)
,wrap ", vEcas = " indentA (\_->showHSName) (vEcas fSpec)
, ", fSwitchboard = "++showHS flags indentA (fSwitchboard fSpec)
,wrap ", vpatterns = " indentA (\_->showHSName) (patterns fSpec)
,wrap ", conceptDefs = " indentA (showHS flags) (conceptDefs fSpec)
,wrap ", fSexpls = " indentA (showHS flags) (fSexpls fSpec)
, ", metas = allMetas"
,wrap ", initialPops = " indentA (showHS flags) (initialPops fSpec)
,wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec)
,"}"
] ++
indent++"where"++
"\n -- ***Interfaces Specified in Ampersand script***: "++
indent++" interfaceS' = "++(if null (interfaceS fSpec) then "[]" else
"[ "++intercalate (indentB++" , ") (map showHSName (interfaceS fSpec))++indentB++" ]")++
"\n -- ***Activities Generated by the Ampersand compiler ***: " ++
indent++" interfaceG' = "++(if null (interfaceG fSpec) then "[]" else
"[ "++intercalate (indentB++", ") (map showHSName (interfaceG fSpec))++indentB++"]")++
indent++" allMetas = "++(if null (metas fSpec) then "[]" else
"[ "++intercalate (indentB++", ") (map (showHS flags (indent ++ " ")) (metas fSpec))++indentB++"]") ++
(if null (interfaceS fSpec) then "" else
"\n -- *** User defined interfaces (total: "++(show.length.interfaceS) fSpec++" interfaces) ***: "++
concat [indent++" "++showHSName s++indent++" = "++showHS flags (indent++" ") s | s<-interfaceS fSpec]++"\n"
)++
(if null (interfaceG fSpec ) then "" else
"\n -- *** Generated interfaces (total: "++(show.length.interfaceG) fSpec++" interfaces) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-interfaceG fSpec ]++"\n"
)++
(let ds fs = allDecls fs `uni` allUsedDecls fs `uni` vrels fSpec `uni` nub (map qDcl (vquads fs)) in
if null (ds fSpec) then "" else
"\n -- *** Declared relations (in total: "++(show.length.ds) fSpec++" relations) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-ds fSpec]++"\n"
) ++
(if null (vIndices fSpec) then "" else
"\n -- *** Indices (total: "++(show.length.vIndices) fSpec++" indices) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vIndices fSpec]++"\n"
) ++
(if null (vviews fSpec) then "" else
"\n -- *** Views (total: "++(show.length.vviews) fSpec++" views) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vviews fSpec]++"\n"
) ++
(if null (vprocesses fSpec ) then "" else
"\n -- *** Processes (total: "++(show.length.vprocesses) fSpec++" processes) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vprocesses fSpec ]++"\n"++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-map fpProc (vprocesses fSpec) ]++"\n"
) ++
(if null (vrules fSpec ) then "" else
"\n -- *** User defined rules (total: "++(show.length.vrules) fSpec++" rules) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vrules fSpec ]++"\n"++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-map srrel (vrules fSpec)]++"\n"
)++
(if null (grules fSpec ) then "" else
"\n -- *** Generated rules (total: "++(show.length.grules) fSpec++" rules) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-grules fSpec ]++"\n"++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-map srrel (grules fSpec)]++"\n"
)++
(if null (vconjs fSpec ) then "" else
"\n -- *** Conjuncts (total: "++(show.length.vconjs) fSpec++" conjuncts) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vconjs fSpec ]++"\n"
)++
(if null (vquads fSpec ) then "" else
"\n -- *** Quads (total: "++(show.length.vquads) fSpec++" quads) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vquads fSpec ]++"\n"
)++
(if null (vEcas fSpec ) then "" else
"\n -- *** ECA rules (total: "++(show.length.vEcas) fSpec++" ECA rules) ***: "++
concat [indent++" "++showHSName eca++indent++" = "++showHS flags (indent++" ") eca |eca<-vEcas fSpec ]++"\n"++
concat [indent++" "++showHSName rel++indent++" = "++showHS flags (indent++" ") rel |rel<-nub(map ecaDelta (vEcas fSpec)) ]++"\n"
)++
(if null (plugInfos fSpec ) then "" else
"\n -- *** PlugInfos (total: "++(show.length.plugInfos) fSpec++" plugInfos) ***: "++
concat [indent++" "++showHSName p++indent++" = "++showHS flags (indent++" ") p |InternalPlug p<-sortBy (compare `on` name) (plugInfos fSpec) ]++"\n"
)++
(if null (vpatterns fSpec) then "" else
"\n -- *** Patterns (total: "++(show.length.vpatterns) fSpec++" patterns) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x |x<-vpatterns fSpec]++"\n"
)++
(if null (allConcepts fSpec) then "" else
"\n -- *** Concepts (total: "++(show.length.allConcepts) fSpec++" concepts) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS flags (indent++" ") x
++ indent++" "++showAtomsOfConcept x |x<-sortBy (comparing showHSName) (allConcepts fSpec)]++"\n"
)
where indentA = indent ++" "
indentB = indent ++" "
showAtomsOfConcept c =
"-- atoms: [ "++ intercalate indentC strs++"]"
where
strs = map show (sort (atomsOf (gens fSpec)(initialPops fSpec) c))
indentC = if sum (map length strs) > 300
then indent ++ " -- , "
else ", "
showViolatedRule :: String -> (Rule,Pairs) -> String
showViolatedRule indent' (r,ps)
= intercalate indent'
[ " ( "++showHSName r++" -- This is "++(if isSignal r then "a process rule." else "an invariant")++
indent'++" , "++ wrap "" (indent'++" ") (let showPair _ p = show p
in showPair) ps++
indent'++" )"
]
instance ShowHS Meta where
showHS f i (Meta pos obj nm val) = "Meta ("++showHS f i pos ++ ") "++ show obj ++ " " ++ show nm ++ " " ++ show val
instance ShowHSName PlugInfo where
showHSName (InternalPlug p) = haskellIdentifier ("ipl_"++name p)
showHSName (ExternalPlug _) = fatal 336 "a PlugInfo is anonymous with respect to showHS flags"
instance ShowHS PlugInfo where
showHS _ _ (InternalPlug p)
= "InternalPlug "++showHSName p
showHS flags ind (ExternalPlug o)
= "ExternalPlug "++showHS flags (ind++" ") o
instance ShowHS RoleRelation where
showHS flags ind rr
= "RR "++show (rrRoles rr)++" "++showHS flags (ind++" ") (rrRels rr)++" "++showHS flags (ind++" ") (rrPos rr)
instance ShowHS RoleRule where
showHS flags ind rs
= "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS flags (ind++" ") (mPos rs)
instance ShowHSName FSid where
showHSName (FS_id nm ) = haskellIdentifier nm
instance ShowHS FSid where
showHS _ _ (FS_id nm)
= "(FS_id " ++ show nm ++ ")"
instance ShowHSName Pattern where
showHSName pat = haskellIdentifier ("pat_"++name pat)
instance ShowHS Pattern where
showHS flags indent pat
= intercalate indentA
[ "A_Pat { ptnm = "++show (name pat)
, ", ptpos = "++showHS flags "" (ptpos pat)
, ", ptend = "++showHS flags "" (ptend pat)
, ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} " | null (ptrls pat)] ++"]"
, wrap ", ptgns = " indentB (showHS flags) (ptgns pat)
, ", ptdcs = [ " ++intercalate (indentB++", ") [showHSName d | d<-ptdcs pat] ++ concat [" {- no relations -} " | null (ptdcs pat)] ++indentB++"]"
, wrap ", ptups = " indentB (showHS flags) (ptups pat)
, case ptrruls pat of
[] -> ", ptrruls = [] {- no role-rule assignments -}"
[(rol,rul)] -> ", ptrruls = [ ("++show rol++", "++showHSName rul++") ]"
rs -> ", ptrruls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"
, case ptrrels pat of
[] -> ", ptrrels = [] {- no role-relation assignments -}"
[(rol,rel)] -> ", ptrrels = [ ("++show rol++", "++showHS flags "" rel++") ]"
rs -> ", ptrrels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"
, wrap ", ptids = " indentB (showHS flags) (ptids pat)
, wrap ", ptxps = " indentB (showHS flags) (ptxps pat)
, "}"
] where indentA = indent ++" "
indentB = indentA++" "
instance ShowHSName FProcess where
showHSName prc = haskellIdentifier ("fprc_"++name (fpProc prc))
instance ShowHS FProcess where
showHS flags indent prc
= intercalate indentA
[ "FProc { fpProc = "++showHSName (fpProc prc)
, wrap ", fpActivities = " indentB (showHS flags) (fpActivities prc)
, " }"
] where indentA = indent ++" "
indentB = indentA++" "
instance ShowHSName Process where
showHSName prc = haskellIdentifier ("prc_"++name prc)
instance ShowHS Process where
showHS flags indent prc
= intercalate indentA
[ "Proc { prcNm = "++show (name prc)
, ", prcPos = "++showHS flags "" (prcPos prc)
, ", prcEnd = "++showHS flags "" (prcEnd prc)
, ", prcRules = [" ++intercalate ", " [showHSName r | r<-prcRules prc] ++ concat [" {- no rules -} " | null (prcRules prc)] ++"]"
, wrap ", prcGens = " indentB (showHS flags) (prcGens prc)
, ", prcDcls = [" ++intercalate ", " [showHSName d | d<-prcDcls prc] ++ concat [" {- no relations -} " | null (prcDcls prc)] ++"]"
, wrap ", prcUps = " indentB (showHS flags) (prcUps prc)
, case prcRRuls prc of
[] -> ", prcRRuls = [] {- no role-rule assignments -}"
[(rol,rul)] -> ", prcRRuls = [ ("++show rol++", "++showHSName rul++") ]"
rs -> ", prcRRuls = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHSName rul++")" | (rol,rul)<-rs] ++indentB++"]"
, case prcRRels prc of
[] -> ", prcRRels = [] {- no role-relation assignments -}"
[(rol,rel)] -> ", prcRRels = [ ("++show rol++", "++showHS flags "" rel++") ]"
rs -> ", prcRRels = [ "++intercalate (indentB++", ") ["("++show rol++", "++showHS flags "" rel++")" | (rol,rel)<-rs] ++indentB++"]"
, wrap ", prcIds = " indentB (showHS flags) (prcIds prc)
, wrap ", prcVds = " indentB (showHS flags) (prcVds prc)
, wrap ", prcXps = " indentB (showHS flags) (prcXps prc)
, "}"
] where indentA = indent ++" "
indentB = indentA++" "
instance ShowHS Activity where
showHS flags indent act =
intercalate indentA
[ "Act { actRule = "++showHSName (actRule act)
, wrap ", actTrig = " indentB (\_->showHSName) (actTrig act)
, wrap ", actAffect = " indentB (\_->showHSName) (actAffect act)
, wrap ", actQuads = " indentB (\_->showHSName) (actQuads act)
, wrap ", actEcas = " indentB (\_->showHSName) (actEcas act)
, wrap ", actPurp = " indentB (\_->(showHS flags indentB)) (actPurp act)
, " }"
]
where indentA = indent ++replicate (length "Act " ) ' '
indentB = indentA++replicate (length ", actAffect = ") ' '
instance ShowHS PPurpose where
showHS flags _ expl =
"PRef2 ("++showHS flags "" (pexPos expl)++") "++
"("++showHS flags "" (pexObj expl)++") "++
"("++showHS flags "" (pexMarkup expl)++") "
++show (intercalate ";" (pexRefIDs expl))++" "
instance ShowHS PRef2Obj where
showHS _ _ peObj
= case peObj of
PRef2ConceptDef str -> "PRef2ConceptDef " ++show str
PRef2Declaration (PTrel _ nm sgn) -> "PRef2Declaration "++show nm++show sgn
PRef2Declaration (Prel _ nm) -> "PRef2Declaration "++show nm
PRef2Declaration expr -> fatal 583 ("Expression "++show expr++" should never occur in PRef2Declaration")
PRef2Rule str -> "PRef2Rule " ++show str
PRef2IdentityDef str -> "PRef2IdentityDef "++show str
PRef2ViewDef str -> "PRef2ViewDef " ++show str
PRef2Pattern str -> "PRef2Pattern " ++show str
PRef2Process str -> "PRef2Process " ++show str
PRef2Interface str -> "PRef2Interface " ++show str
PRef2Context str -> "PRef2Context " ++show str
PRef2Fspc str -> "PRef2Fspc " ++show str
instance ShowHS Purpose where
showHS flags _ expla =
"Expl "++"("++showHS flags "" (explPos expla)++") "
++"("++showHS flags "" (explObj expla)++") "
++showHS flags "" (explMarkup expla)++" "
++show (explUserdefd expla)++" "
++show (explRefIds expla)++" "
instance ShowHS ExplObj where
showHS flags i peObj = case peObj of
ExplConceptDef cd -> "ExplConceptDef " ++showHS flags i cd
ExplDeclaration d -> "ExplDeclaration "++showHSName d
ExplRule str -> "ExplRule " ++show str
ExplIdentityDef str-> "ExplIdentityDef "++show str
ExplViewDef str -> "ExplViewDef " ++show str
ExplPattern str -> "ExplPattern " ++show str
ExplProcess str -> "ExplProcess " ++show str
ExplInterface str -> "ExplInterface " ++show str
ExplContext str -> "ExplContext " ++show str
instance ShowHS P_Markup where
showHS _ indent m
= intercalate indent
["P_Markup{ mLang = "++ show (mLang m)
," , mFormat = "++ show (mFormat m)
," , mString = "++ show (mString m)
," }"
]
instance ShowHS A_Markup where
showHS _ indent m
= intercalate indent
["A_Markup{ amLang = "++ show (amLang m)
," , amFormat = "++ show (amFormat m)
," , amPandoc = "++ show (amPandoc m)
," }"
]
instance ShowHS (PairView Expression) where
showHS flags indent (PairView pvs) = "PairView "++showHS flags indent pvs
instance ShowHS (PairViewSegment Expression) where
showHS _ _ (PairViewText txt) = "PairViewText "++show txt
showHS flags _ (PairViewExp srcOrTgt e) = "PairViewExp "++show srcOrTgt++" ("++showHS flags "" e++")"
instance ShowHSName Rule where
showHSName r = haskellIdentifier ("rule_"++ rrnm r)
instance ShowHS Rule where
showHS flags indent r@(Ru _ _ _ _ _ _ _ _ _ _ _ _)
= intercalate indent
["Ru{ rrnm = " ++ show (rrnm r)
," , rrexp = -- " ++ showADL (rrexp r) ++ indent++" " ++ showHS flags (indent++" ") (rrexp r)
," , rrfps = " ++ showHS flags "" (rrfps r)
," , rrmean = " ++ showHS flags (indent++" ") (rrmean r)
," , rrmsg = " ++ showHS flags "" (rrmsg r)
," , rrviol = " ++ showHS flags "" (rrviol r)
," , rrtyp = " ++ showHS flags "" (rrtyp r)
," , rrdcl = " ++ case rrdcl r of
Just (p,d) -> "Just ("++showHSName p++", "++showHSName d++" )"
Nothing -> "Nothing"
," , r_env = " ++ show (r_env r)
," , r_usr = " ++ show (r_usr r)
," , isSignal = " ++ show (isSignal r)
," , srrel = " ++ showHSName (srrel r)
," }"
]
instance ShowHS AMeaning where
showHS flags indent (AMeaning x) = "AMeaning " ++ showHS flags (indent++" ") x
instance ShowHS RuleType where
showHS _ _ Truth = "Truth"
showHS _ _ Equivalence = "Equivalence"
showHS _ _ Implication = "Implication"
instance ShowHSName IdentityDef where
showHSName identity = haskellIdentifier ("identity_"++name identity)
instance ShowHS IdentityDef where
showHS flags indent identity
= "Id ("++showHS flags "" (idPos identity)++") "++show (idLbl identity)++" ("++showHSName (idCpt identity)++")"
++indent++" [ "++intercalate (indent++" , ") (map (showHS flags indent) $ identityAts identity)++indent++" ]"
instance ShowHS IdentitySegment where
showHS flags indent (IdentityExp objDef) = "IdentityExp ("++ showHS flags indent objDef ++ ")"
instance ShowHSName ViewDef where
showHSName vd = haskellIdentifier ("vdef_"++name vd)
instance ShowHS ViewDef where
showHS flags indent vd
= "Vd ("++showHS flags "" (vdpos vd)++") "++show (vdlbl vd)++" "++showHSName (vdcpt vd)
++indent++" [ "++intercalate (indent++" , ") (map (showHS flags indent) $ vdats vd)++indent++" ]"
instance ShowHS ViewSegment where
showHS _ _ (ViewText str) = "ViewText "++show str
showHS _ _ (ViewHtml str) = "ViewHtml "++show str
showHS flags indent (ViewExp objDef) = "ViewExp "++ showHS flags (indent++" ") objDef
instance ShowHS Population where
showHS _ indent pop
= case pop of
PRelPopu{} -> "PRelPopu { popdcl = "++showHSName (popdcl pop)
++indent++" , popps = [ "++intercalate
(indent++" , ") (map show (popps pop))
++indent++" ]"
++indent++" }"
PCptPopu{} -> "PCptPopu { popcpt = "++showHSName (popcpt pop)
++indent++" , popas = [ "++intercalate
(indent++" , ") (map show (popas pop))
++indent++" ]"
++indent++" }"
instance ShowHSName ObjectDef where
showHSName obj = haskellIdentifier ("oDef_"++name obj)
instance ShowHS ObjectDef where
showHS flags indent r
= intercalate indent
["Obj{ objnm = " ++ show(objnm r)
," , objpos = " ++ showHS flags "" (objpos r)
," , objctx = " ++ showHS flags (indent++" ") (objctx r)
," , objmsub = " ++ showHS flags (indent++" ") (objmsub r)
," , objstrs = " ++ show(objstrs r)
]++indent++" }"
instance ShowHSName Interface where
showHSName obj = haskellIdentifier ("ifc_"++name obj)
instance ShowHS Interface where
showHS flags indent ifc
= intercalate indent
[ wrap "Ifc { ifcParams = " (indent++" ") (showHS flags) (ifcParams ifc)
, " , ifcArgs = " ++ show(ifcArgs ifc)
, " , ifcRoles = " ++ show(ifcRoles ifc)
, " , ifcObj"++indent++" = " ++ showHS flags (indent++" ") (ifcObj ifc)
, " , ifcPos = " ++ showHS flags "" (ifcPos ifc)
, " , ifcPrp = " ++ show(ifcPrp ifc)
]++indent++" }"
instance ShowHS SubInterface where
showHS _ _ (InterfaceRef n) = "InterfaceRef "++show n
showHS flags indent (Box x objs) = "Box ("++showHS flags indent x++")"++indent++" ("++showHS flags (indent++" ") objs++")"
instance ShowHS Expression where
showHS flags indent (EEqu (l,r)) = "EEqu ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EImp (l,r)) = "EImp ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EIsc (l,r)) = "EIsc ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EUni (l,r)) = "EUni ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EDif (l,r)) = "EDif ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (ELrs (l,r)) = "ELrs ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (ERrs (l,r)) = "ERrs ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EDia (l,r)) = "EDia ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (ECps (l,r)) = "ECps ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (ERad (l,r)) = "ERad ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EPrd (l,r)) = "EPrd ("++showHS flags (indent++" ") l++indent++" ,"++showHS flags (indent++" ") r++indent++" )"
showHS flags indent (EKl0 e ) = "EKl0 ("++showHS flags (indent++" ") e++")"
showHS flags indent (EKl1 e ) = "EKl1 ("++showHS flags (indent++" ") e++")"
showHS flags indent (EFlp e ) = "EFlp ("++showHS flags (indent++" ") e++")"
showHS flags indent (ECpl e ) = "ECpl ("++showHS flags (indent++" ") e++")"
showHS flags indent (EBrk e ) = "EBrk ("++showHS flags (indent++" ") e++")"
showHS _ _ (EDcD dcl ) = "EDcD "++showHSName dcl
showHS _ _ (EDcI c ) = "EDcI "++showHSName c
showHS flags _ (EEps i sgn) = "EEps ("++showHS flags "" i++") ("++showHS flags "" sgn++")"
showHS flags _ (EDcV sgn ) = "EDcV ("++showHS flags "" sgn++")"
showHS _ _ (EMp1 a c ) = "EMp1 " ++show a++" "++showHSName c
instance ShowHS Sign where
showHS _ _ sgn = "Sign "++showHSName (source sgn)++" "++showHSName (target sgn)
instance ShowHS A_Gen where
showHS _ _ gen =
case gen of
Isa{} -> "Isa "++showHSName (genspc gen)++" "++showHSName (gengen gen)++" "
IsE{} -> "IsE "++showHSName (genspc gen)++" ["++intercalate ", " (map showHSName (genrhs gen))++"] "
instance ShowHSName Declaration where
showHSName d@Isn{} = haskellIdentifier ("rel_"++name d++"_"++name (source d))
showHSName d@Vs{} = haskellIdentifier ("rel_"++name d++"_"++name (source d)++name (target d))
showHSName d | decusr d = haskellIdentifier ("rel_"++name d++name (source d)++name (target d))
| deciss d = haskellIdentifier ("sgn_"++name d++name (source d)++name (target d))
| otherwise = haskellIdentifier ("vio_"++name d++name (source d)++name (target d))
instance ShowHS Declaration where
showHS flags indent d
= case d of
Sgn{} -> intercalate indent
["Sgn{ decnm = " ++ show (decnm d)
," , decsgn = " ++ showHS flags "" (sign d)
," , decprps = " ++ showL(map (showHS flags "") (decprps d))
," , decprps_calc = " ++ case decprps_calc d of
Nothing -> "Nothing"
Just ps -> "Just "++showL(map (showHS flags "") ps)
," , decprL = " ++ show (decprL d)
," , decprM = " ++ show (decprM d)
," , decprR = " ++ show (decprR d)
," , decMean = " ++ show (decMean d)
," , decfpos = " ++ showHS flags "" (decfpos d)
," , deciss = " ++ show (deciss d)
," , decusr = " ++ show (decusr d)
," , decpat = " ++ show (decpat d)
," , decplug = " ++ show (decplug d)
]++"}"
Isn{} -> "Isn{ detyp = " ++ showHSName (detyp d)++"}"
Vs{} -> "Vs { decsgn = " ++ showHS flags "" (sign d)++"}"
instance ShowHS ConceptDef where
showHS flags _ cd
= " Cd ("++showHS flags "" (cdpos cd)++") "++show (cdcpt cd)++" "++show (cdplug cd)++" "++show (cddef cd)++" "++show (cdtyp cd)++" "++show (cdref cd)++" "++show (cdfrom cd)
instance ShowHSName Char where
showHSName c = show c
instance ShowHS Char where
showHS _ _ c = show c
instance ShowHSName A_Concept where
showHSName ONE = haskellIdentifier "cptOne"
showHSName c = haskellIdentifier ("cpt_"++name c)
instance ShowHS A_Concept where
showHS _ _ c = case c of
PlainConcept{} -> "PlainConcept "++show (name c)
ONE -> "ONE"
instance ShowHS FPcompl where
showHS _ _ = show
instance ShowHS FPA where
showHS _ _ (FPA t c) = "FPA "++show t++" "++show c
instance ShowHSName Prop where
showHSName Uni = "Uni"
showHSName Inj = "Inj"
showHSName Sur = "Sur"
showHSName Tot = "Tot"
showHSName Sym = "Sym"
showHSName Asy = "Asy"
showHSName Trn = "Trn"
showHSName Rfx = "Rfx"
showHSName Irf = "Irf"
instance ShowHS Prop where
showHS _ _ = showHSName
instance ShowHS FilePos where
showHS _ _ (FilePos (fn,DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner.Pos l c,sym))
= "FilePos ("++show fn++",Pos "++show l++" "++show c++","++show sym++")"
instance ShowHSName Origin where
showHSName ori = "Orig"++show x++show (hash x)
where x = case ori of
FileLoc l -> "FileLoc (" ++ show l++")"
DBLoc l -> "DBLoc " ++ show l
Origin s -> "Origin " ++ show s
OriginUnknown -> "OriginUnknown"
instance ShowHS Origin where
showHS flags indent (FileLoc l) = "FileLoc (" ++ showHS flags indent l++")"
showHS _ _ (DBLoc l) = "DBLoc " ++ show l
showHS _ _ (Origin s) = "Origin " ++ show s
showHS _ _ OriginUnknown = "OriginUnknown"
instance ShowHS Block where
showHS _ _ = show
instance ShowHS Inline where
showHS _ _ = show
haskellIdentifier :: String -> String
haskellIdentifier cs = unCap (hsId cs)
where
hsId ('_': cs') = '_': hsId cs'
hsId (c:cs') | isAlphaNum c = c: hsId cs'
| otherwise = hsId cs'
hsId "" = ""
showL :: [String] -> String
showL xs = "["++intercalate "," xs++"]"