ampersand-3.0.3: src/Database/Design/Ampersand/FSpec/ShowHS.hs
{-# OPTIONS_GHC -XFlexibleInstances #-}
module Database.Design.Ampersand.FSpec.ShowHS (ShowHS(..),ShowHSName(..),fSpec2Haskell,haskellIdentifier) where
import Database.Design.Ampersand.Core.ParseTree
import Database.Design.Ampersand.Core.AbstractSyntaxTree
import Text.Pandoc hiding (Meta)
import Data.Char (isAlphaNum)
import Database.Design.Ampersand.Basics hiding (indent)
import Database.Design.Ampersand.FSpec.Plug
import Database.Design.Ampersand.FSpec.FSpec
import Database.Design.Ampersand.FSpec.ShowADL (ShowADL(..)) -- for traceability, we generate comments in the Haskell code.
--import Database.Design.Ampersand.FSpec.FPA (fpa)
import Data.List
import Database.Design.Ampersand.Classes
import qualified Database.Design.Ampersand.Input.ADL1.UU_Scanner
import Database.Design.Ampersand.Misc
import Data.Hashable
import Data.Ord
import Data.Function
fatal :: Int -> String -> a
fatal = fatalMsg "FSpec.ShowHS"
fSpec2Haskell :: FSpec -> String
fSpec2Haskell fSpec
= "{-# OPTIONS_GHC -Wall #-}"
++"\n{-Generated code by "++ampersandVersionStr++" at "++show (genTime (getOpts fSpec))++"-}"
++"\nmodule Main where\n"
++"\nimport Database.Design.Ampersand"
++"\nimport Text.Pandoc hiding (Meta)"
++"\nimport Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn)"
++"\n"
++"\nmain :: IO ()"
++"\nmain = do (getOpts fSpec) <- getOptions"
++"\n putStr (showHS (getOpts fSpec) \"\\n \" fSpec_"++baseName (getOpts fSpec)++")\n"
++"\nfSpec_"++baseName (getOpts fSpec)++" :: FSpec"
++"\nfSpec_"++baseName (getOpts fSpec)++" =\n "++showHS (getOpts fSpec) "\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 opts indent = wrap "" (indent++" ") (showHS opts)
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 opts indent (Just x) = "Just (" ++ showHS opts indent x ++ ")"
instance (ShowHSName a , ShowHSName b) => ShowHSName (a,b) where
showHSName (a,b) = "( "++showHSName a++" , "++showHSName b++" )"
-- | The following is used to showHS opts for signs: (Concept, Concept)
-- instance (ShowHS a , ShowHS b) => ShowHS (a,b) where
-- showHS opts indent (a,b) = "("++showHS opts (indent++" ") a++","++showHS opts (indent++" ") b++")"
instance ShowHSName PlugSQL where
showHSName plug = haskellIdentifier ("plug_"++name plug)
instance ShowHS PlugSQL where
showHS opts indent plug
= case plug of
TblSQL{} -> intercalate indent
["let " ++ intercalate (indent++" ")
[showHSName f++indent++" = "++showHS opts (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 opts "" r++", "++showHSName ms++", "++showHSName mt++")" | (r,ms,mt)<-mLkpTbl plug] ++ "]"
-- ," , sqlfpa = " ++ showHS opts "" (fpa plug)
," }"
]
BinSQL{} -> intercalate indent
["let " ++ showHSName (fst (columns plug))++indent++" = "++showHS opts (indent++" ") (fst (columns plug))
++ (indent++" ") ++ showHSName (snd (columns plug))++indent++" = "++showHS opts (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 opts "" (mLkp plug)
-- ," , sqlfpa = " ++ showHS opts "" (fpa plug)
," }"
]
ScalarSQL{} -> intercalate indent
["ScalarSQL { sqlname = "++ (show.name) plug
," , sqlColumn = "++ showHS opts (indent++" ") (sqlColumn plug)
," , cLkp = "++ showHSName (cLkp plug)
-- ," , sqlfpa = "++ showHS opts "" (fpa plug)
," }"
]
instance ShowHSName (ECArule) where
showHSName r = "ecaRule"++show (ecaNum r)
instance ShowHS (ECArule) where
showHS opts indent r
= "ECA { ecaTriggr = " ++ showHS opts "" (ecaTriggr r) ++
indent++" , ecaDelta = " ++ showHSName (ecaDelta r)++
indent++" , ecaAction = " ++ showHS opts (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 opts indent (tOp, links, p)
= "( "++show tOp++indent++", "++showHS opts (indent++" ") links++indent++", "++showHS opts (indent++" ") p++indent++")"
instance ShowHS PAclause where
showHS opts indent p
= case p of
CHC{} -> wrap "CHC " (indent ++" ") (showHS opts) (paCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
GCH{} -> wrap "GCH " (indent ++" ") (showHS opts) (paGCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
ALL{} -> wrap "ALL " (indent ++" ") (showHS opts) (paCls p)++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Do{} -> "Do "++show (paSrt p)++" "++showHSName (paTo p)++
indent++" ("++showHS opts (indent++" ") (paDelta p)++indent++" )"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
New{} -> "New ("++showHS opts "" (paCpt p)++")"++
indent++" (\\x->"++showHS opts (indent++" ") (paCl p "x")++indent++" )"++
wrap (if null ms then "" else indent ++" ") (indent ++" ") showMotiv ms
Rmv{} -> "Rmv ("++showHS opts "" (paCpt p)++")"++
indent++" (\\x->"++showHS opts (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 opts) (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 opts (ind++" ") conj++" -- conjunct: "++showADL conj++ind++", "++showHSName rs++ind++")"
instance ShowHSName SqlField where
showHSName sqFd = haskellIdentifier ("sqlFld_"++fldname sqFd)
instance ShowHS SqlField where
showHS opts indent sqFd
= intercalate indentA
[ "Fld { fldname = " ++ show (fldname sqFd)
, ", fldexpr = " ++ showHS opts indentB (fldexpr sqFd)
, ", fldtype = " ++ showHS opts "" (fldtype sqFd)
, ", flduse = " ++ showHS opts "" (flduse sqFd)
, ", fldnull = " ++ show (fldnull sqFd)
, ", flduniq = " ++ show (flduniq sqFd)
, "}"
] where indentA = indent ++" " -- adding the width of "Fld "
indentB = indentA++" " -- adding the width of ", fldexpr = "
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.qRule) q)
instance ShowHS Quad where
showHS _ indent q
= intercalate indent
[ "Quad{ qDcl = " ++ showHSName (qDcl q)
, " , qRule = " ++ showHSName (qRule q)
, wrap " , qConjuncts = " newindent (\_->showHSName) (qConjuncts q)
, " }"
]
where
newindent = indent ++ " "
instance ShowHS Fswitchboard where
showHS opts indent fsb
= intercalate indent
[ "Fswtch { fsbEvIn = " ++ showHS opts newindent (fsbEvIn fsb)
, " , fsbEvOut = " ++ showHS opts 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 opts newindent'' conj++newindent++" )"
instance ShowHS DnfClause where
showHS opts indent dnf
= intercalate indent
[ wrap "Dnf " (indent++" ") (\_->showHS opts (indent++" ")) (antcs dnf)
, wrap " " (indent++" ") (\_->showHS opts (indent++" ")) (conss dnf)
]
instance ShowHSName Conjunct where
showHSName x = haskellIdentifier (rc_id x)
instance ShowHS Conjunct where
showHS opts indent x
= intercalate (indent ++" ")
[ "Cjct{ rc_id = " ++ show (rc_id x)
, ", rc_orgRules = " ++ "[ "++intercalate (", ") (map showHSName (rc_orgRules x))++"]"
, ", rc_conjunct = " ++ showHS opts indentA (rc_conjunct x)
, wrap ", rc_dnfClauses = " indentA (\_->showHS opts (indentA++" ")) (rc_dnfClauses x)
, "}"
]
where indentA = indent ++" "
instance ShowHSName FSpec where
showHSName fSpec = haskellIdentifier ("fSpc_"++name fSpec)
instance ShowHS FSpec where
showHS opts indent fSpec
= intercalate (indent ++" ")
[ "FSpec{ fsName = " ++ show (name fSpec)
,wrap ", fspos = " indentA (showHS opts) (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 ", rulesInScope = " indentA (\_->showHSName) (rulesInScope fSpec)
,wrap ", declsInScope = " indentA (\_->showHSName) (declsInScope fSpec)
,wrap ", cDefsInScope = " indentA (\_->showHS opts (indentA++" ")) (cDefsInScope fSpec)
,wrap ", gensInScope = " indentA (showHS opts) (gensInScope fSpec)
,wrap ", vplugInfos = " indentA (\_->showHS opts (indentA++" ")) (vplugInfos fSpec)
,wrap ", plugInfos = " indentA (\_->showHS opts (indentA++" ")) (plugInfos fSpec)
, ", interfaceS = interfaceS'"
, ", interfaceG = interfaceG'"
,wrap ", fActivities = " indentA (\_->showHS opts (indentA++" ")) (fActivities fSpec)
, ", fRoleRels = " ++
case fRoleRels fSpec of
[] -> "[]"
[(r,rel)] -> "[ ("++show r++", "++showHS opts "" rel++") ]"
_ -> "[ "++intercalate (indentA++", ") ["("++show r++","++showHS opts "" rel++")" | (r,rel)<-fRoleRels fSpec]++indentA++"]"
, ", fRoleRuls = " ++showHS opts indentA (fRoleRuls fSpec)
,wrap ", fRoles = " indentA (showHS opts) (fRoles fSpec)
,wrap ", vrules = " indentA (\_->showHSName) (vrules fSpec)
,wrap ", grules = " indentA (\_->showHSName) (grules fSpec)
,wrap ", invariants = " indentA (\_->showHSName) (invariants fSpec)
,wrap ", fallRules = " indentA (\_->showHSName) (fallRules 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 opts) (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 opts indentA (fSwitchboard fSpec)
,wrap ", vpatterns = " indentA (\_->showHSName) (vpatterns fSpec)
,wrap ", conceptDefs = " indentA (showHS opts) (conceptDefs fSpec)
,wrap ", fSexpls = " indentA (showHS opts) (fSexpls fSpec)
, ", metas = allMetas"
,wrap ", initialPops = " indentA (showHS opts) (initialPops fSpec)
,wrap ", allViolations = " indentA showViolatedRule (allViolations fSpec)
,wrap ", allExprs = " indentA (showHS opts) (allExprs 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 opts (indent ++ " ")) (metas fSpec))++indentB++"]") ++
-- WHY? staan hier verschillende lijstjes met interfaces?
-- BECAUSE! Een Ampersand engineer besteedt veel tijd om vanuit een kennismodel (lees: een graaf met concepten en relaties)
-- alle interfaces met de hand te verzinnen.
-- Je kunt natuurlijk ook een interfaces-generator aan het werk zetten, die een aantal interfaces klaarzet bij wijze
-- van steiger (scaffold). Dat bespaart een hoop werk. De functie interfaceG is zo'n generator.
-- Door de gegenereerde interfaces af te drukken, kun je dus heel snel Ampersand sourcecode maken met correct-vertaalbare interfaces.
-- Heb je eenmaal een goed werkend pakket interfaces, dan wil je wellicht alleen de door jezelf gespecificeerde interfaces
-- gebruiken. Dat gebeurt in interfaceS.
(if null (interfaceS fSpec) then "" else
"\n -- *** User defined interfaces (total: "++(show.length.interfaceS) fSpec++" interfaces) ***: "++
concat [indent++" "++showHSName s++indent++" = "++showHS opts (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 opts (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 opts (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 opts (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 opts (indent++" ") x |x<-vviews fSpec]++"\n"
) ++
(if null (vrules fSpec ) then "" else
"\n -- *** User defined rules (total: "++(show.length.vrules) fSpec++" rules) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS opts (indent++" ") x |x<-vrules fSpec ]++"\n"
)++
(if null (grules fSpec ) then "" else
"\n -- *** Generated rules (total: "++(show.length.grules) fSpec++" rules) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS opts (indent++" ") x |x<-grules fSpec ]++"\n"
)++
(if null (vconjs fSpec ) then "" else
"\n -- *** Conjuncts (total: "++(show.length.vconjs) fSpec++" conjuncts) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS opts (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 opts (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 opts (indent++" ") eca |eca<-vEcas fSpec ]++"\n"++
concat [indent++" "++showHSName rel++indent++" = "++showHS opts (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 opts (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 opts (indent++" ") x |x<-vpatterns fSpec]++"\n"
)++
-- (if null (conceptDefs fSpec) then "" else
-- "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "++
-- concat [indent++" "++showHSName cd++indent++" = "++showHS opts (indent++" ") cd | c<-concs fSpec, cd<-concDefs fSpec c]++"\n"
-- )++
(if null (allConcepts fSpec) then "" else
"\n -- *** Concepts (total: "++(show.length.allConcepts) fSpec++" concepts) ***: "++
concat [indent++" "++showHSName x++indent++" = "++showHS opts (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 (vgens 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 --"( "++ (show.fst) p++", "++(show.snd) 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)-- TODO
showHSName (ExternalPlug _) = fatal 336 "a PlugInfo is anonymous with respect to showHS opts"
instance ShowHS PlugInfo where
showHS _ _ (InternalPlug p)
= "InternalPlug "++showHSName p
showHS opts ind (ExternalPlug o)
= "ExternalPlug "++showHS opts (ind++" ") o
instance ShowHS A_RoleRelation where
showHS opts ind rr
= "RR "++show (rrRoles rr)++" "++showHS opts (ind++" ") (rrRels rr)++" "++showHS opts (ind++" ") (rrPos rr)
instance ShowHS Role where
showHS _ ind (Role str) = ind++"Role "++show str
instance ShowHS P_RoleRule where
showHS opts ind rs
= "Maintain "++show (mRoles rs)++" "++show (mRules rs)++" "++showHS opts (ind++" ") (mPos rs)
instance ShowHS (Role,Rule) where
showHS _ _ (rol,rul)
= "("++show rol++", "++showHSName rul++")"
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 opts indent pat
= intercalate indentA
[ "A_Pat { ptnm = "++show (name pat)
, ", ptpos = "++showHS opts "" (ptpos pat)
, ", ptend = "++showHS opts "" (ptend pat)
, ", ptrls = [" ++intercalate ", " [showHSName r | r<-ptrls pat] ++ concat [" {- no rules -} " | null (ptrls pat)] ++"]"
, wrap ", ptgns = " indentB (showHS opts) (ptgns pat)
, ", ptdcs = [ " ++intercalate (indentB++", ") [showHSName d | d<-ptdcs pat] ++ concat [" {- no relations -} " | null (ptdcs pat)] ++indentB++"]"
, wrap ", ptups = " indentB (showHS opts) (ptups pat)
, wrap ", ptids = " indentB (showHS opts) (ptids pat)
, wrap ", ptvds = " indentB (showHS opts) (ptvds pat)
, wrap ", ptxps = " indentB (showHS opts) (ptxps pat)
, "}"
] where indentA = indent ++" " -- adding the width of "A_Pat "
indentB = indentA++" " -- adding the width of ", ptrls = "
instance ShowHS Activity where
showHS opts 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 opts indentB)) (actPurp act)
, " }"
]
where indentA = indent ++replicate (length ("Act "::String)) ' '
indentB = indentA++replicate (length (", actAffect = " :: String)) ' '
instance ShowHS PPurpose where
showHS opts _ expl =
"PRef2 ("++showHS opts "" (pexPos expl)++") "++
"("++showHS opts "" (pexObj expl)++") "++
"("++showHS opts "" (pexMarkup expl)++") "
++show (intercalate ";" (pexRefIDs expl))++" "
instance ShowHS PRef2Obj where
showHS _ _ peObj
= case peObj of
PRef2ConceptDef str -> "PRef2ConceptDef " ++show str
PRef2Declaration (PNamedRel _ nm mSgn) -> "PRef2Declaration "++show nm++maybe "" show mSgn
PRef2Rule str -> "PRef2Rule " ++show str
PRef2IdentityDef str -> "PRef2IdentityDef "++show str
PRef2ViewDef str -> "PRef2ViewDef " ++show str
PRef2Pattern str -> "PRef2Pattern " ++show str
PRef2Interface str -> "PRef2Interface " ++show str
PRef2Context str -> "PRef2Context " ++show str
PRef2Fspc str -> "PRef2Fspc " ++show str
instance ShowHS Purpose where
showHS opts _ expla =
"Expl "++"("++showHS opts "" (explPos expla)++") "
++"("++showHS opts "" (explObj expla)++") "
++showHS opts "" (explMarkup expla)++" "
++show (explUserdefd expla)++" "
++show (explRefIds expla)++" "
instance ShowHS ExplObj where
showHS opts i peObj = case peObj of
ExplConceptDef cd -> "ExplConceptDef " ++showHS opts 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
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 opts indent (PairView pvs) = "PairView "++showHS opts indent pvs
instance ShowHS (PairViewSegment Expression) where
showHS _ _ (PairViewText _ txt) = "PairViewText "++show txt
showHS opts _ (PairViewExp _ srcOrTgt e) = "PairViewExp "++show srcOrTgt++" ("++showHS opts "" e++")"
instance ShowHSName Rule where
showHSName r = haskellIdentifier ("rule_"++ rrnm r)
instance ShowHS Rule where
showHS opts indent r@(Ru _ _ _ _ _ _ _ _ _ _ _) -- This pattern matching occurs so Haskell will detect any change in the definition of Ru.
= intercalate indent
["Ru{ rrnm = " ++ show (rrnm r)
," , rrexp = -- " ++ showADL (rrexp r) ++ indent++" " ++ showHS opts (indent++" ") (rrexp r)
," , rrfps = " ++ showHS opts "" (rrfps r)
," , rrmean = " ++ showHS opts (indent++" ") (rrmean r)
," , rrmsg = " ++ showHS opts "" (rrmsg r)
," , rrviol = " ++ showHS opts "" (rrviol r)
," , rrtyp = " ++ showHS opts "" (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)
," }"
]
instance ShowHS AMeaning where
showHS opts indent (AMeaning x) = "AMeaning " ++ showHS opts (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 opts indent identity
= "Id ("++showHS opts "" (idPos identity)++") "++show (idLbl identity)++" ("++showHSName (idCpt identity)++")"
++indent++" [ "++intercalate (indent++" , ") (map (showHS opts indent) $ identityAts identity)++indent++" ]"
instance ShowHS IdentitySegment where
showHS opts indent (IdentityExp objDef) = "IdentityExp ("++ showHS opts indent objDef ++ ")"
instance ShowHSName ViewDef where
showHSName vd = haskellIdentifier ("vdef_"++name vd)
instance ShowHS ViewDef where
showHS opts indent vd
= "Vd ("++showHS opts "" (vdpos vd)++") "++show (vdlbl vd)++" "++showHSName (vdcpt vd)
++indent++" [ "++intercalate (indent++" , ") (map (showHS opts indent) $ vdats vd)++indent++" ]"
--instance ShowHSName ViewSegment where
-- showHSName vd = haskellIdentifier ("vdef_"++name vd)
instance ShowHS ViewSegment where
showHS _ _ (ViewText str) = "ViewText "++show str
showHS _ _ (ViewHtml str) = "ViewHtml "++show str
showHS opts indent (ViewExp objDef) = "ViewExp "++ showHS opts (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 opts indent r
= intercalate indent
["Obj{ objnm = " ++ show(objnm r)
," , objpos = " ++ showHS opts "" (objpos r)
," , objctx = " ++ showHS opts (indent++" ") (objctx r)
," , objmsub = " ++ showHS opts (indent++" ") (objmsub r)
," , objstrs = " ++ show(objstrs r)
]++indent++" }"
instance ShowHSName Interface where
showHSName obj = haskellIdentifier ("ifc_"++name obj)
instance ShowHS Interface where
showHS opts indent ifc
= intercalate indent
[ "Ifc { ifcClass = " ++ show (ifcClass ifc)
, wrap " , ifcParams = " (indent++" ") (showHS opts) (ifcParams ifc)
, " , ifcArgs = " ++ show(ifcArgs ifc)
, " , ifcRoles = " ++ show(ifcRoles ifc)
, " , ifcObj"++indent++" = " ++ showHS opts (indent++" ") (ifcObj ifc)
, " , ifcEcas = " ++ showHS opts (indent++" ") (ifcEcas ifc)
, wrap " , ifcControls = " (indent++" ") (\_->showHSName) (ifcControls ifc)
, " , ifcPos = " ++ showHS opts "" (ifcPos ifc)
, " , ifcPrp = " ++ show(ifcPrp ifc)
]++indent++" }"
instance ShowHS SubInterface where
showHS _ _ (InterfaceRef n) = "InterfaceRef "++show n
showHS opts indent (Box x cl objs) = "Box ("++showHS opts indent x++") ("++showHS opts indent cl++")"++indent++" ("++showHS opts (indent++" ") objs++")"
instance ShowHS Expression where
showHS opts indent (EEqu (l,r)) = "EEqu ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EImp (l,r)) = "EImp ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EIsc (l,r)) = "EIsc ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EUni (l,r)) = "EUni ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EDif (l,r)) = "EDif ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (ELrs (l,r)) = "ELrs ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (ERrs (l,r)) = "ERrs ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EDia (l,r)) = "EDia ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (ECps (l,r)) = "ECps ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (ERad (l,r)) = "ERad ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EPrd (l,r)) = "EPrd ("++showHS opts (indent++" ") l++indent++" ,"++showHS opts (indent++" ") r++indent++" )"
showHS opts indent (EKl0 e ) = "EKl0 ("++showHS opts (indent++" ") e++")"
showHS opts indent (EKl1 e ) = "EKl1 ("++showHS opts (indent++" ") e++")"
showHS opts indent (EFlp e ) = "EFlp ("++showHS opts (indent++" ") e++")"
showHS opts indent (ECpl e ) = "ECpl ("++showHS opts (indent++" ") e++")"
showHS opts indent (EBrk e ) = "EBrk ("++showHS opts (indent++" ") e++")"
showHS _ _ (EDcD dcl ) = "EDcD "++showHSName dcl
showHS _ _ (EDcI c ) = "EDcI "++showHSName c
showHS opts _ (EEps i sgn) = "EEps ("++showHS opts "" i++") ("++showHS opts "" sgn++")"
showHS opts _ (EDcV sgn ) = "EDcV ("++showHS opts "" 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)) -- identity relation
showHSName d@Vs{} = haskellIdentifier ("rel_"++name d++"_"++name (source d)++"_"++name (target d)) -- full relation
showHSName d | decusr d = haskellIdentifier ("rel_"++name d++"_"++name (source d)++"_"++name (target d)) -- user defined relations
| deciss d = haskellIdentifier ("sgn_"++name d++"_"++name (source d)++"_"++name (target d)) -- relations generated for signalling
| otherwise = haskellIdentifier ("vio_"++name d++"_"++name (source d)++"_"++name (target d)) -- relations generated per rule
instance ShowHS Declaration where
showHS opts indent d
= case d of
Sgn{} -> intercalate indent
["Sgn{ decnm = " ++ show (decnm d)
," , decsgn = " ++ showHS opts "" (sign d)
," , decprps = " ++ showL(map (showHS opts "") (decprps d))
," , decprps_calc = " ++ case decprps_calc d of
Nothing -> "Nothing"
Just ps -> "Just "++showL(map (showHS opts "") ps)
," , decprL = " ++ show (decprL d)
," , decprM = " ++ show (decprM d)
," , decprR = " ++ show (decprR d)
," , decMean = " ++ show (decMean d)
," , decfpos = " ++ showHS opts "" (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 opts "" (sign d)++"}"
-- instance ShowHSName ConceptDef where
-- showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd)
instance ShowHS ConceptDef where
showHS opts _ cd
= " Cd ("++showHS opts "" (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 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"
showHSName Aut = "Aut"
instance ShowHS Prop where
showHS _ _ = showHSName
instance ShowHS FilePos where
showHS _ _ (FilePos (fn,Database.Design.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 opts indent (FileLoc l) = "FileLoc (" ++ showHS opts 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
{-
instance ShowHS InfTree where
showHS opts indent itree =
case itree of
InfExprs irt (ratype,raobj) itrees ->
"InfExprs " ++ showHS opts indent irt ++
indent ++ " (" ++ showRaType ratype ++ "," ++ "RelAlgObj{-"++show raobj++"-}" ++ ")" ++
indent ++ showHS opts (indent ++ " ") itrees
InfRel drt ratype _ _ ->
"InfRel " ++ showHS opts indent drt ++ " " ++ showRaType ratype
where
showRaType rat = "RelAlgType{-"++show rat++"-}"
instance ShowHS RelDecl where
showHS _ indent d = case d of
RelDecl{}-> "RelDecl{ dname = " ++ show (dname d) ++ indent
++ " ,dtype = " ++ showRaType dtype ++ indent
++ " ,isendo = " ++ show (isendo d)
IDecl -> "IDecl"
VDecl -> "VDecl"
where
showRaType _ = "RelAlgType{- ++TODO++ -}"
instance ShowHS DeclRuleType where
showHS _ _ drt = case drt of
D_rel -> "D_rel"
D_rel_h -> "D_rel_h"
D_rel_c -> "D_rel_c"
D_rel_c_h -> "D_rel_c_h"
D_id -> "D_id"
D_v -> "D_v"
D_id_c -> "D_id_c"
D_v_c -> "D_v_c"
instance ShowHS InfRuleType where
showHS _ _ irt = case irt of
ISect_cs -> "ISect_cs"
ISect_ncs -> "ISect_ncs"
ISect_mix -> "ISect_mix"
Union_mix -> "Union_mix"
Comp_ncs -> "Comp_ncs"
Comp_c1 -> "Comp_c1"
Comp_c2 -> "Comp_c2"
Comp_cs -> "Comp_cs"
RAdd_ncs -> "RAdd_ncs"
RAdd_c1 -> "RAdd_c1"
RAdd_c2 -> "RAdd_c2"
RAdd_cs -> "RAdd_cs"
Conv_nc -> "Conv_nc"
Conv_c -> "Conv_c"
-}
-- \***********************************************************************
-- \*** hulpfuncties ***
-- \***********************************************************************
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++"]"