{-# LANGUAGE NamedFieldPuns #-} module Database.Design.Ampersand.Prototype.GenBericht (doGenBericht) where import Prelude hiding (writeFile) import Data.List import Text.CSV import System.FilePath import System.Directory import Control.Monad import Database.Design.Ampersand -- TODO: only show Rel and Flp Rel? give error otherwise? -- what about Typ, Brk etc.? fatal :: Int -> String -> a fatal = fatalMsg "GenBericht" -- an intermediate data type, so we can easily generate to several output formats data Entity = Entity { entName :: String , depth :: Int , cardinality :: String , definition :: String , refType :: String , properties :: [Entity] } deriving Show doGenBericht :: FSpec -> IO () doGenBericht fSpec = do { verboseLn (getOpts fSpec) "Generating 'Berichtendefinities'..." ; createDirectoryIfMissing True $ combine (dirPrototype (getOpts fSpec)) "Berichten" ; let entities = genEntity_Interfaces $ interfaceS fSpec ; let berichtenCSV = allEntitiesToCSV entities ; when (development (getOpts fSpec)) $ verboseLn (getOpts fSpec) $ layout berichtenCSV ; genFile "Berichten/Berichten.csv" $ printSemicolonSeparated berichtenCSV ; genFile "Berichten/Gegevenswoordenboek.html" $ genGegevensWB entities ; genFile "Berichten/Berichtdefinitie.html" $ genBerichtDef entities } where genFile filename contents = do { writeFile (combine (dirPrototype (getOpts fSpec)) filename) contents ; verboseLn (getOpts fSpec) $ "\nGenerated file "++filename } genEntity_Interfaces :: [Interface] -> [Entity] genEntity_Interfaces interfaces' = map genEntity_Interface interfaces' where genEntity_Interface :: Interface -> Entity genEntity_Interface interface = genEntity_ObjDef 0 (ifcObj interface) where genEntity_ObjDef :: Int -> ObjectDef -> Entity genEntity_ObjDef dpth objDef = Entity { entName = name objDef , depth = dpth , cardinality = card $ objctx objDef , definition = def $ objctx objDef , refType = name (target $ objctx objDef) , properties = case objmsub objDef of Nothing -> [] Just (Box _ _ objs) -> map (genEntity_ObjDef (dpth+1)) objs Just (InterfaceRef nm) -> map (genEntity_ObjDef (dpth+1)) $ objsForInterfaceNamed nm } where card e = (if isTot e then "1" else "0")++".."++(if isUni e then "1" else "*") def rel = case concDefs fSpec (target rel) of Cd {cddef=def'} : _ | def' /= "" -> def' _ -> "** NO DEFINITION **" objsForInterfaceNamed :: String -> [ObjectDef] objsForInterfaceNamed nm = case objmsub $ ifcObj $ getInterfaceByName interfaces' nm of Just (Box _ _ objs) -> objs _ -> fatal 81 "Bericht interfaces have wrong format" -- NOTE: We ignore the interface relation for interfaces refs allEntitiesToCSV :: [Entity] -> CSV allEntitiesToCSV entities = ["Naam", "Card.", "Definitie", "Type"] : intercalate [["","","",""]] (map entityToCSV entities) entityToCSV :: Entity -> CSV entityToCSV (Entity nm dpth card def refTp props) = [ concat (replicate dpth ". ") ++ nm, card, def, refTp] : concatMap entityToCSV props -- Utils layout :: [[String]] -> String layout linez = let columns = transpose linez formatColumn col = let width = maximum . map length $ col in map (fill width) col in unlines . map unwords . transpose . map formatColumn $ columns where fill i str = str ++ take (i - length str) (replicate i ' ') -- Modified version of Text.CSV.printCSV printSemicolonSeparated :: CSV -> String printSemicolonSeparated records = unlines (printRecord `map` records) where printRecord = intercalate ";" . map printField printField f = "\"" ++ concatMap escape f ++ "\"" escape '"' = "\"\"" escape x = [x] -- Html genGegevensWB :: [Entity] -> String genGegevensWB entities = gegevensWB_Header ++ gegevensWB_Toc ++ gegevensWB_Middle ++ concatMap gegevensWB_Element entities ++ gegevensWB_Footer where gegevensWB_Toc :: String gegevensWB_Toc = unlines [ "
  • " ++ mkLocalLink concept' concept' ++ "
    • " | Entity{ entName = concept' } <- entities ] -- TODO: it's not the concept, but the interface name, yet refTp is a concept? or also an interface name? gegevensWB_Element :: Entity -> String gegevensWB_Element (Entity concept' _ _ _ _ props) = wbElement_Header ++ concatMap (wbElement_Element concept') props ++ wbElement_Footer where wbElement_Header :: String wbElement_Header = " " ++ mkAnchor concept' ++ "
    \n" ++ "
    "++concept'++"
    \n" ++ "
    "++concept'++"
    \n" ++ " \n" ++ " \n" where mkAnchor :: String -> String mkAnchor entityName = " \n" wbElement_Element :: String -> Entity -> String wbElement_Element parentConcept (Entity _ _ card def refTp _) = " \n" ++ " \n" ++ -- NOTE: don't want def twice here "
    \n" ++ " \n" ++ -- TODO: leave out if this is not a defined data type " \n" wbElement_Footer :: String wbElement_Footer = "
    Property termCardinalityRepresentation term
    "++def++""++card++"" ++ mkLink entities refTp refTp ++ "
    \n" ++ "
    \n" gegevensWB_Header :: String gegevensWB_Header = "\n" ++ "\n" ++ "\n" ++ "\n" ++ "Rechtspraak 2011-11-25 20:14:20\n" ++ "\n" ++ "\n" ++ "\n" ++ "\n" ++ "
    \n" ++ "
    \n" ++ "

    Aggregate BIEs

    \n" ++ "
      \n" gegevensWB_Middle :: String gegevensWB_Middle = "
    \n" ++ "
    \n" ++ "
    \n" ++ "
    \n" ++ "
    \n" gegevensWB_Footer :: String gegevensWB_Footer = "
    \n" ++ "
    \n" ++ "\n" ++ "\n" mkLocalLink :: String -> String -> String mkLocalLink nm html = "    " ++ html ++ "" mkLink :: [Entity] -> String -> String -> String mkLink entities nm html = if isEntity entities nm then "\n"++ html ++ "" else html isEntity :: [Entity] -> String -> Bool isEntity entities nm = (not.null) (filter ((==nm) . entName) entities) genBerichtDef :: [Entity] -> String genBerichtDef entities = berichtDef_Header ++ berichtDef_Toc ++ berichtDef_Middle ++ concatMap berichtDef_ElementLine entities ++ berichtDef_Footer where berichtDef_Toc :: String berichtDef_Toc = unlines [ "
  • "++entNm++"
    • " | Entity{ entName = entNm } <- entities ] berichtDef_ElementLine :: Entity -> String berichtDef_ElementLine (Entity entNm depth card def refTp props) = " \n" ++ " \n" ++ " " ++ mkLink entities refTp entNm ++ " \n" ++ " "++card++"\n" ++ " "++def++"\n" ++ " \n" ++ concatMap berichtDef_ElementLine props where padding = if depth > 0 then " style=\"padding-left:"++show (depth*25)++"px\"" else "" -- Html-page strings berichtDef_Header :: String berichtDef_Header = "\n" ++ "\n" ++ "\n" ++ "\n" ++ "Documentation for Aanlevering Zaakstuk\n" ++ "\n" ++ "\n" ++ "\n" ++ "\n" ++ "

    Business Document - AanleveringZaakstuk_BD-023011

    \n" ++ "
    \n" ++ "

    Document Information

    \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ " \n" ++ "
    Object Class TermAanlevering Zaakstuk
    Qualifier Term
    Version1.1.0.0
    Unique IdentifierBD-023011
    Release Identifier1.1RC02
    Date2011-11-25
    DefinitionGebruikt om stukken aan te leveren aan de Rechtsprekende Instantie.
    Comments'Generiek' BD Aanlevering Zaakstuk. 1.1 heeft voorschot salaris toegevoegd - specifiek voor DDI
    Document HeaderThe XML schema for this business document includes the http://data.justid.nl/common/header-1 header(s).
    \n" ++ "

    Document Properties

    \n" ++ "
      \n" berichtDef_Middle :: String berichtDef_Middle = "
    \n" ++ "
    \n" ++ "
    \n" ++ " \n" ++ " \n" berichtDef_Footer :: String berichtDef_Footer = " \n" ++ "\n" ++ "\n" ++ "\n"
    Property termCardinalityDefinition