{-# OPTIONS_GHC -Wall -XFlexibleInstances #-} 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(..)) -- for traceability, we generate comment in the Haskell code. -- import DatabaseDesign.Ampersand.Fspec.FPA (fpa) 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++" )" -- | The following is used to showHS flags for signs: (Concept, Concept) -- instance (ShowHS a , ShowHS b) => ShowHS (a,b) where -- showHS flags indent (a,b) = "("++showHS flags (indent++" ") a++","++showHS flags (indent++" ") 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] ++ "]" -- ," , sqlfpa = " ++ showHS flags "" (fpa 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) -- ," , sqlfpa = " ++ showHS flags "" (fpa plug) ," }" ] ScalarSQL{} -> intercalate indent ["ScalarSQL { sqlname = "++ (show.name) plug ," , sqlColumn = "++ showHS flags (indent++" ") (sqlColumn plug) ," , cLkp = "++ showHSName (cLkp plug) -- ," , sqlfpa = "++ showHS flags "" (fpa 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 ++" " -- 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.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++"]") ++ -- 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 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 (conceptDefs fSpec) then "" else -- "\n -- *** ConceptDefs (total: "++(show.length.conceptDefs) fSpec++" conceptDefs) ***: "++ -- concat [indent++" "++showHSName cd++indent++" = "++showHS flags (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 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 --"( "++ (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 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 ++" " -- adding the width of "A_Pat " indentB = indentA++" " -- adding the width of ", ptrls = " 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 ++" " -- adding the width of "FProc " indentB = indentA++" " -- adding the width of ", fpActivities = " 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 ++" " -- adding the width of "FProc " indentB = indentA++" " -- adding the width of ", prcRules = " 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 _ _ _ _ _ _ _ _ _ _ _ _) -- 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 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 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 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)) -- 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 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 ShowHSName ConceptDef where -- showHSName cd = haskellIdentifier ("cDef_"++cdcpt cd) 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 -- instance ShowHS InfTree where -- showHS flags indent itree = -- case itree of -- InfExprs irt (ratype,raobj) itrees -> -- "InfExprs " ++ showHS flags indent irt ++ -- indent ++ " (" ++ showRaType ratype ++ "," ++ "RelAlgObj{-"++show raobj++"-}" ++ ")" ++ -- indent ++ showHS flags (indent ++ " ") itrees -- InfRel drt ratype _ _ -> -- "InfRel " ++ showHS flags 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++"]"