packages feed

CSPM-ToProlog (empty) → 0.3.1.0

raw patch · 6 files changed

+769/−0 lines, 6 filesdep +CSPM-Frontenddep +basedep +containerssetup-changed

Dependencies added: CSPM-Frontend, base, containers, pretty

Files

+ CSPM-ToProlog.cabal view
@@ -0,0 +1,34 @@+Name:                CSPM-ToProlog+Version:             0.3.1.0+Synopsis:            some modules specific for the ProB tool+Description:+  This package constains a translation from a CSPM AST to the representation+  used by the ProB tool.+  This code is only interesting for ProB developers.++License:             BSD3+category:            Formal Methods+License-File:        LICENSE+Author:              2006-2011 Marc Fontaine+Maintainer:          Marc Fontaine <fontaine@cs.uni-duesseldorf.de>+HomePage:            http://www.stups.uni-duesseldorf.de/ProB+Cabal-Version:  >= 1.10+Tested-With:    GHC==7.0.2+Build-Type:     Simple++Library+  Default-Language: Haskell2010+  Build-Depends:+    CSPM-Frontend >= 0.6 && < 0.7+    ,pretty >= 1.0 && < 1.1+    ,base >= 4.0 && <5.0+    ,containers >= 0.4 && <0.5++  Hs-Source-Dirs: src+  ghc-options: -Wall++  Exposed-modules:+    Language.CSPM.AstToProlog+    Language.CSPM.TranslateToProlog+  Other-modules:+    Language.Prolog.PrettyPrint.Direct
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Marc Fontaine 2007-2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ src/Language/CSPM/AstToProlog.hs view
@@ -0,0 +1,402 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.CSPM.AstToProlog+-- Copyright   :  (c) Fontaine, Dobrikov 2011+-- License     :  BSD3+-- +-- Maintainer  :  fontaine@cs.uni-duesseldorf.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Translation of an AST into Prolog terms, suitable for the ProB CSPM-Interpreter+-- +-----------------------------------------------------------------------------+{-# OPTIONS_GHC -Wall -Werror -fno-warn-warnings-deprecations #-}++module Language.CSPM.AstToProlog+(+ cspToProlog+,mkSymbolTable+,mkSrcLoc+)+where++import Language.CSPM.Frontend (ModuleFromRenaming)+import Language.CSPM.AST+import qualified Language.CSPM.SrcLoc as SrcLoc+import Language.Prolog.PrettyPrint.Direct++import Text.PrettyPrint+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.IntMap as IntMap++-- | Translate a "LModule" into a "Doc" containing a number of Prolog facts.+-- The LModule must be a renamed,i.e. contain only unique "Ident"ifier.+cspToProlog ::+  ModuleFromRenaming -- ^ the renamed Module+  -> Doc  -- ^ prolog facts+cspToProlog ast = +  let+     core = mkModule ast+     header = +       (text ":- dynamic channel/2, bindval/3, agent/3.")+       $+$ +       (text ":- dynamic agent_curry/3, symbol/4.")+       $+$ +       (text ":- dynamic dataTypeDef/2, subTypeDef/2, nameType/2.")+       $+$+       (text ":- dynamic cspTransparent/1.")+       $+$+       (text ":- dynamic cspPrint/1.")+   in header $+$ core++plLocatedConstructs :: Set Const+plLocatedConstructs = Set.fromList +  [F_Interleave , F_Interrupt, F_Timeout, F_CHAOS,+   F_ExtChoice, F_IntChoice, F_Sequential, F_Hiding+  ]++mkModule :: ModuleFromRenaming -> Doc+mkModule m+  = plPrg [declGroup $ map clause $ declList $ moduleDecls m]++te :: LExp -> Term+te expr = case unLabel expr of+  Var i -> let u = unUIdent $ unLabel i in+    case (prologMode u,idType u) of+      (PrologGround,VarID)   -> nTerm "val_of" [plNameTerm i, plLoc expr]+      _ -> plNameTerm i+  IntExp i -> nTerm "int" [atom i]+  SetExp r Nothing -> nTerm "setExp" [range r]+  SetExp r (Just comp) -> nTerm "setExp" [range r, comprehension comp]+  ListExp r Nothing -> nTerm "listExp" [range r]+  ListExp r (Just comp) -> nTerm "listExp" [range r, comprehension comp]+  ClosureComprehension (e,c) ->  nTerm "closureComp" [comprehension c ,eList e] +  Let decl e -> nTerm "let" [pList $ declList decl, te e]+  Ifte cond t e -> nTerm "ifte" [te cond, te t, te e,condPos,thenPos,elsePos] where+    condPos = mkSrcLoc $ SrcLoc.srcLocFromTo (srcLoc expr) (srcLoc cond)+    thenPos = mkSrcLoc $ SrcLoc.srcLocBetween (srcLoc cond) (srcLoc t)+    elsePos = mkSrcLoc $ SrcLoc.srcLocBetween (srcLoc t) (srcLoc e)+  CallFunction fkt args -> case args of+     [l] -> nTerm "agent_call" [plLoc fkt, te fkt, eList l]+     (_:_:_) -> nTerm "agent_call_curry" [te fkt, pList $ map eList args ]+     [] -> error ("CallFunction without args" ++ show expr)+  CallBuiltIn builtIn args+    -> if ((unBuiltIn builtIn) `Set.member` plLocatedConstructs )+          then nTerm "builtin_call" [ nTerm (builtInToString builtIn) (plLoc expr : flatArgs args) ]+          else nTerm "builtin_call" [ nTerm (builtInToString builtIn) $ flatArgs args ]+  Lambda patl e -> nTerm "lambda" [pList $ map tp patl, te e]+  Stop  -> nTerm "stop" [plLoc expr]+  Skip  -> nTerm "skip" [plLoc expr]+  CTrue -> aTerm "true"+  CFalse -> aTerm "false"+  Events -> aTerm "Events"+  BoolSet -> aTerm "boolType"+  IntSet  -> aTerm "intType"+  ProcSet -> aTerm "procType"+  TupleExp i -> nTerm "tupleExp" [eList i]+  Parens e -> term $ te e+  AndExp a b -> nTerm "bool_and" [te a, te b]+  OrExp a b -> nTerm "bool_or" [te a, te b]+  NotExp a -> nTerm "bool_not" [te a]+  NegExp a -> nTerm "negate" [te a]+  Fun1 op a -> nTerm (builtInToString op) [te a]+  Fun2 op a b -> if ((unBuiltIn op) `Set.member` plLocatedConstructs ) +    then nTerm (builtInToString op) [te a, te b, plLoc expr]+    else nTerm (builtInToString op) [te a, te b]+  DotTuple a -> nTerm "dotTuple" [eList a]+  Closure l -> nTerm "closure" [ eList l]+  ProcSharing al p1 p2 -> nTerm "sharing" [te al, te p1, te p2,plLoc expr]+  ProcAParallel a1 a2 p1 p2+    -> nTerm "aParallel" [te a1, te p1, te a2, te p2, plLoc expr]+  ProcLinkParallel ll a b+    ->  nTerm "lParallel" [ linkList ll, te a, te b, plLoc ll ] +  ProcRenaming ren Nothing p+    -> nTerm "procRenaming" [ renameList ren, te p, plLoc expr ]+  ProcRenaming ren (Just gen) p+    -> nTerm "procRenamingComp" [te p, comprehension $ unLabel gen, renameList ren]+  ProcException p1 e p2 -> nTerm "exception" [te p1, te e, te p2, plLoc expr]+  ProcRepSequence gen proc -> nTerm "repSequence" [comprehension $ unLabel gen, te proc, plLoc gen]+  ProcRepInternalChoice gen proc +    -> nTerm "repInternalChoice" [comprehension $ unLabel gen, te proc, plLoc gen]+  ProcRepInterleave gen proc +    -> nTerm "repInterleave" [comprehension $ unLabel gen, te proc, plLoc gen]+  ProcRepExternalChoice gen proc -> nTerm "repChoice" [comprehension $ unLabel gen, te proc, plLoc gen]+  ProcRepAParallel gen alph proc+    -> nTerm "procRepAPrallel" [comprehension $ unLabel gen, nTerm "pair" [te alph, te proc] ,plLoc gen]+  ProcRepLinkParallel gen links proc+    -> nTerm "procRepLinkPrallel" [linkList links, comprehension $ unLabel gen, te proc, plLoc gen]+  ProcRepSharing gen share proc+    -> nTerm "procRepSharing" [te share, comprehension $ unLabel gen, te proc, plLoc gen]+  PrefixExp ch fields proc -> nTerm "prefix" [plLoc ch, mkCommFields fields, te ch, te proc,prefixLoc ]+    where+      prefixLoc = mkSrcLoc $ SrcLoc.srcLocBetween+        (if null fields then srcLoc $ ch else srcLoc $ last fields)+        (srcLoc proc)+  PrefixI {} -> missingCase "PrefixI"+  ExprWithFreeNames {} -> missingCase "ExprWithFreeNames"+  LambdaI {} -> missingCase "LambdaI"+  LetI {} -> missingCase "LetI"+  where+    missingCase :: String -> Term+    missingCase s = error $ "missing case in te :" ++ s+    flatArgs :: [[LExp]] -> [Term]+    flatArgs l = concatMap (map te) l  ++    comprehension :: [LCompGen] -> Term+    comprehension l = pList $ map (comp . unLabel ) l+      where+        comp (Guard e) = nTerm "comprehensionGuard" [te e]+        comp (Generator pat e) = nTerm "comprehensionGenerator" [tp pat, te e]++    linkList :: LLinkList -> Term+    linkList ll = case unLabel ll of+      LinkList l -> nTerm "linkList" [ pList $ map (mklink . unLabel) l ]+      LinkListComprehension gen l +        -> nTerm "linkListComp" [ comprehension gen, pList $ map (mklink . unLabel) l ]+      where+        mklink (Link a b) = nTerm "link" [te a,te b]++    renameList :: [LRename] -> Term+    renameList l = pList $ map (mkRen . unLabel) l+      where+        mkRen (Rename a b) = nTerm "rename" [te a, te b]+    mkCommFields :: [LCommField] -> Term+    mkCommFields l = pList $ map (mkCF . unLabel) l+      where+        mkCF (InComm p) = nTerm "in" [tp p]+        mkCF (OutComm e) = nTerm "out" [te e]+        mkCF (InCommGuarded p e) = nTerm "inGuard" [tp p, te e]++    range :: LRange -> Term+    range r = case unLabel r of+      RangeOpen a -> nTerm "rangeOpen" [te a]+      RangeClosed a b -> nTerm "rangeClosed" [te a, te b]+      RangeEnum l -> nTerm "rangeEnum" [eList l]++eList :: [LExp] -> Term+eList l = pList h+  where h :: [Term]+        h = map te l++tp :: LPattern -> Term+tp pattern = case unLabel pattern of+  IntPat i -> nTerm "int" [atom i]+  TruePat -> aTerm "true"+  FalsePat -> aTerm "false"+  WildCard -> plWildCard+  VarPat i -> plNameTerm i+  ConstrPat i -> plNameTerm i+  Also l -> tpList "alsoPattern" l+  Append l ->  tpList "appendPattern" l+  DotPat l ->  tpList "dotpat" l+  SingleSetPat p -> tpList "singleSetPat" [p]+  EmptySetPat -> aTerm "emptySet"+  ListEnumPat l -> tpList "listPat" l+  TuplePat l -> tpList "tuplePat" l+  Selector {} -> error "missing case in tp : Selector"+  Selectors {} -> error "missing case in tp : Selectors"+  where+    tpList :: String -> [LPattern] -> Term+    tpList f l =  nTerm f [pList $ map tp l]++declList :: [LDecl] -> [Term]+declList l = concatMap td l++td :: LDecl -> [Term]+td decl = case unLabel decl of+  PatBind pat e -> [ nTerm "bindval" [tp pat, te e, plLoc decl]]+  FunBind fkt caseList -> map (mkFunBind fkt) caseList+  Assert e -> mkAssert e+  Transparent idList +    -> [ nTerm "cspTransparent" [pList $ map plName idList] ]+  SubType i constrL  -> [ nTerm "subTypeDef"  [plNameTerm i, mkConstructorList constrL] ]+  DataType i constrL -> [ nTerm "dataTypeDef" [plNameTerm i, mkConstructorList constrL] ]+  NameType i t -> [ nTerm "nameType" [plNameTerm i, nTerm "type" [mkTypeDef t]] ]+  Channel ids tdef -> map (mkChannel tdef) ids+  Print e -> [ nTerm "cspPrint" [te e] ]+  where+    mkFunBind :: LIdent -> FunCase -> Term+    mkFunBind ident (FunCase pat e) = case pat of +      [p] -> nTerm "agent" [+              nTerm (plName ident) $ map tp p+             ,te e+             ,plLoc ident]+      l -> nTerm "agent_curry" [+              nTerm (plName ident) $ map (pList . map tp) l +             ,te e+             ,plLoc ident]+    mkFunBind _ (FunCaseI {}) = error "unexpected case in mkFunBind: FunCaseI"+    mkConstructorList :: [LConstructor] -> Term+    mkConstructorList l = pList $ map mkConstructor l+    mkConstructor :: LConstructor -> Term+    mkConstructor c = case unLabel c of+      Constructor i Nothing  -> nTerm "constructor" [plNameTerm i]+      Constructor i (Just t) -> nTerm "constructorC" [plNameTerm i, mkTypeDef t]++    mkTypeDef :: LTypeDef -> Term+    mkTypeDef t = case unLabel t of+      TypeTuple l -> nTerm "typeTuple" [eList l]+      TypeDot   l -> nTerm "dotTupleType" [eList l]+   +    mkChannel :: Maybe LTypeDef -> LIdent -> Term+    mkChannel Nothing  i = nTerm "channel" [ plNameTerm i, nTerm "type" [term $ atom "dotUnitType" ]]+    mkChannel (Just t) i = nTerm "channel" [ plNameTerm i, nTerm "type" [mkTypeDef t]]++++    mkAssert :: LAssertDecl -> [Term]+    mkAssert ass = case unLabel ass of+      AssertBool e -> [ nTerm "assertBool" [te e] ]+      AssertRefine b p1 m p2+        -> [ nTerm "assertRef" [aTerm $ show b, te p1, termShow m, te p2, plLoc decl] ]+      AssertTauPrio b p1 m p2 e+        -> [ nTerm "assertTauPrio" [aTerm $ show b, te p1, termShow m, te p2, te e, plLoc decl] ]+      AssertModelCheck b p m (Just ext)+        -> [ nTerm "assertModelCheckExt" [aTerm $ show b, te p, termShow m, termShow ext] ]+      AssertModelCheck b p m Nothing+        -> [ nTerm "assertModelCheck" [aTerm $ show b, te p, termShow m ] ]+    termShow :: Show a => Labeled a -> Term+    termShow = aTerm . show . unLabel++plName :: LIdent -> Atom+plName l+  = let uIdent = unUIdent $ unLabel l in case idType uIdent of+    TransparentID -> atom $ realName uIdent+    VarID         -> error ("plName : " ++ show l)+    _             -> atom $ uniquePlName uIdent++plNameTerm :: LIdent -> Term+plNameTerm l+  = let uIdent = unUIdent $ unLabel l in case (idType uIdent,prologMode uIdent) of+    (VarID,PrologVariable) -> plVar ("_" ++ uniquePlName uIdent)+    (VarID,PrologGround)   -> term $ atom $ uniquePlName uIdent+    _             -> term $ plName l+{-+{- fix me , temporal hack, switchoff renaming for channel,etc-}+    (FunID _,_)   -> term $ atom $ uniquePlName uIdent+    (_,_)         -> term $ atom $ uniquePlName uIdent -- <- TODO,FIX BUG+-}++uniquePlName :: UniqueIdent -> String+uniquePlName i = newName i+++plLoc :: Labeled x -> Term+plLoc = mkSrcLoc . srcLoc++-- | Translate a source location to Prolog+mkSrcLoc :: SrcLoc.SrcLoc -> Term+mkSrcLoc loc =  case loc of+  SrcLoc.TokPos {} ->  nTerm "src_position" +      [itt $ SrcLoc.getStartLine loc+      ,itt $ SrcLoc.getStartCol loc+      ,itt $ SrcLoc.getStartOffset loc+      ,itt $ SrcLoc.getTokenLen loc ]+  SrcLoc.TokSpan {} -> nTerm "src_span"+      [itt $ SrcLoc.getStartLine loc+      ,itt $ SrcLoc.getStartCol loc+      ,itt $ SrcLoc.getEndLine loc+      ,itt $ SrcLoc.getEndCol loc+      ,itt $ SrcLoc.getStartOffset loc+      ,itt $ SrcLoc.getTokenLen loc ]+  SrcLoc.FixedLoc {} -> nTerm "src_span"+      [itt $ SrcLoc.getStartLine loc+      ,itt $ SrcLoc.getStartCol loc+      ,itt $ SrcLoc.getEndLine loc+      ,itt $ SrcLoc.getEndCol loc+      ,itt $ SrcLoc.getStartOffset loc+      ,itt $ SrcLoc.getTokenLen loc ]+  _ -> term $ atom "no_loc_info_available"+  where +    itt :: Int -> Term+    itt = term . iatom . fromIntegral+    iatom :: Integer -> Atom+    iatom = atom+++-- | Translate a "AstAnnotation" with "UnqiueIdentifier" (i.e. a Symboltable)+-- into a "Doc" containing Prolog facts+mkSymbolTable :: AstAnnotation UniqueIdent -> Doc+mkSymbolTable ids +  = plPrg [declGroup $ map mkSymbol $ IntMap.elems ids]+  where+  mkSymbol :: UniqueIdent -> Clause+  mkSymbol i = clause $ nTerm "symbol"+   [aTerm $ uniquePlName i+   ,aTerm $ realName i+   ,mkSrcLoc $ bindingLoc i+   ,aTerm $ pprintIDType i+   ]+  pprintIDType :: UniqueIdent -> String+  pprintIDType i = case idType i of+    ChannelID -> "Channel"+    NameTypeID -> "Nametype"+    (FunID x) -> "Funktion or Process ( Arity :"++show x ++")"+    (ConstrID d)   -> "Constructor of Datatype "++d+    DataTypeID     -> "Datatype"+    TransparentID  -> "Transparent function"+    VarID -> case prologMode i of+      PrologGround -> "Ident (Groundrep.)"+      PrologVariable -> "Ident (Prolog Variable)"++++-- | Map the abstract datatype LBuiltIn back to plain Strings for Prolog+builtInToString :: LBuiltIn -> String+builtInToString x = +  let (BuiltIn bi) = unLabel x in+  case bi of+  F_STOP -> "STOP"     +  F_SKIP -> "SKIP"     +  F_true -> "true"     +  F_false -> "false"+  F_not -> "not"      +  F_and -> "and"      +  F_or -> "or"       +  F_Int -> "Int"      +  F_Bool -> "Bool"     +  F_Events -> "Events"   +  F_CHAOS -> "CHAOS"    +  F_union -> "union"    +  F_inter -> "inter"    +  F_diff -> "diff"     +  F_Union -> "Union"    +  F_Inter -> "Inter"    +  F_member -> "member"   +  F_card -> "card"     +  F_empty -> "empty"    +  F_set -> "set"      +  F_Set -> "Set"      +  F_Seq -> "Seq"      +  F_null -> "null"     +  F_head -> "head"     +  F_tail -> "tail"     +  F_concat -> "concat"   +  F_elem -> "elem"     +  F_length -> "length"   +  F_Concat -> "^"        +  F_Len2 -> "#"        +  F_Mult -> "*"        +  F_Div -> "/"        +  F_Mod -> "%"        +  F_Add -> "+"        +  F_Sub -> "-"      +  F_Eq -> "=="       +  F_NEq -> "!="       +  F_GE -> ">="       +  F_LE -> "<="       +  F_LT -> "<"        +  F_GT -> ">"        +  F_Guard -> "&"        +  F_Sequential -> ";"        +  F_Interrupt -> "/\\"      +  F_ExtChoice -> "[]"       +  F_Timeout -> "[>"       +  F_IntChoice -> "|~|"      +  F_Interleave -> "|||"      +  F_Hiding -> "\\"        ++unBuiltIn :: LBuiltIn -> Const+unBuiltIn x =  let (BuiltIn fkt) = unLabel x in fkt
+ src/Language/CSPM/TranslateToProlog.hs view
@@ -0,0 +1,159 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.CSPM.TranslateToProlog+-- Copyright   :  (c) Fontaine 2010 - 2011+-- License     :  BSD3+-- +-- Maintainer  :  fontaine@cs.uni-duesseldorf.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- Translate a CSPM-specification to Prolog.+-- This is the interface used by Prolog+-----------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}+module Language.CSPM.TranslateToProlog+(+  translateToProlog+)+where++import Language.CSPM.Frontend as Frontend+import qualified Language.CSPM.SrcLoc as SrcLoc+import qualified Language.CSPM.Token as Token (lexEMsg,lexEPos,alexLine,alexCol,alexPos)+import Language.CSPM.AstToProlog (cspToProlog,mkSymbolTable)+import Language.Prolog.PrettyPrint.Direct++import Control.Exception+import System.Exit+import System.CPUTime+import Text.PrettyPrint++-- | 'translateToProlog' reads a CSPM specification from inFile+-- and writes the Prolog representation to outFile.+-- It handles all lexer and parser errors and catches all exceptions.+translateToProlog ::+     FilePath -- ^ filename input+  -> FilePath -- ^ filename output+  -> IO ()+translateToProlog inFile outFile = do+  res <- handle catchAllExceptions+          $ handleLexError lexErrorHandler+             $ handleParseError parseErrorHandler+               $ handleRenameError renameErrorHandler $ mainWork inFile+  (r :: Either SomeException ()) <- try $ writeFile outFile res+  case r of+    Right () -> return ()+    Left err -> do+      putStrLn "output-file not written"+      putStrLn $ show err+      exitFailure++{-+main :: IO ()+main = do+  args <- getArgs+  case args of+    [inFile,outFile] -> do+      translateToProlog inFile outFile+      exitSuccess+    _ -> do+      putStrLn "Start with two arguments (input filename and output filename)"+      exitFailure+-}++mainWork :: FilePath -> IO String+mainWork fileName = do+  src <- readFile fileName++  printDebug $ "Reading File " ++ fileName+  startTime <- (return $ length src) >> getCPUTime+  tokenList <- lexInclude src >>= eitherToExc+  time_have_tokens <- getCPUTime++  ast <- eitherToExc $ parse fileName tokenList+  time_have_ast <- getCPUTime++  printDebug $ "Parsing OK"+  printDebug $ "lextime : " ++ showTime (time_have_tokens - startTime)+  printDebug $ "parsetime : " ++ showTime(time_have_ast - time_have_tokens)+  +  time_start_renaming <- getCPUTime+  (astNew,renaming) <- eitherToExc $ renameModule ast+  let+    plCode = cspToProlog astNew+    symbolTable = mkSymbolTable $ identDefinition renaming+  output <- evaluate $ show $ vcat [ +      mkResult "ok" "" 0 0 0+     ,plCode+     ,symbolTable+     ]++  time_have_renaming <- getCPUTime+  printDebug $ "renamingtime : " ++ showTime (time_have_renaming - time_start_renaming)+  printDebug $ "total : " ++ showTime(time_have_ast - startTime)+  return output++showTime :: Integer -> String+showTime a = show (div a 1000000000) ++ "ms"++defaultHeader :: Doc+defaultHeader +  = text ":- dynamic parserVersionNum/1, parserVersionStr/1, parseResult/5."+--    $$ simpleFact "parserVersionNum" [aTerm versionNum ]+--    $$ simpleFact "parserVersionStr" [aTerm versionStr ]++simpleFact :: String -> [Term] -> Doc+simpleFact a l= plPrg [declGroup [clause $ nTerm a l]]++mkResult :: String -> String -> Int -> Int -> Int -> Doc+mkResult var msg line col pos+  = defaultHeader   +    $$ simpleFact "parseResult" [aTerm var, aTerm msg, aTerm line, aTerm col, aTerm pos]++printDebug :: String -> IO ()+printDebug _ = return ()+--printDebug = putStrLn++parseErrorHandler :: ParseError -> IO String+parseErrorHandler err = do+  printDebug "ParseError : "+  printDebug $ show err+  let loc = Frontend.parseErrorPos err+  evaluate $ show+    $ mkResult "parseError"+        (Frontend.parseErrorMsg err)+        (Token.alexLine loc)+        (Token.alexCol loc)+        (Token.alexPos loc)++lexErrorHandler :: LexError -> IO String+lexErrorHandler err = do+  printDebug "LexError : "+  printDebug $ show err+  let loc = Token.lexEPos err+  evaluate $ show+    $ mkResult "lexError"+        (Token.lexEMsg err)+        (Token.alexLine loc)+        (Token.alexCol loc)+        (Token.alexPos loc)++renameErrorHandler :: RenameError -> IO String+renameErrorHandler err = do +  printDebug "RenamingError : "+  printDebug $ show err+  let loc = Frontend.renameErrorLoc err+  evaluate $ show+    $ mkResult "renameError"+        (Frontend.renameErrorMsg err)+        (SrcLoc.getStartLine loc)+        (SrcLoc.getStartCol loc)+        (SrcLoc.getStartOffset loc)++catchAllExceptions :: SomeException -> IO String+catchAllExceptions err = do+  printDebug "ParserException : "+  printDebug $ show err+  evaluate $ show $ mkResult "exception" (show err) 0 0 0
+ src/Language/Prolog/PrettyPrint/Direct.hs view
@@ -0,0 +1,144 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Prolog.PrettyPrint.Direct+-- Copyright   :  (c) Fontaine 2010 - 2011+-- License     :  BSD3+-- +-- Maintainer  :  fontaine@cs.uni-duesseldorf.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- A very simple DSL for generating for Prolog-Syntax.+-- Just some newtypes and smart-constructors.+--+-----------------------------------------------------------------------------+{-+--  this is all buggy+-- todo:+--  separate package for Prolog-Syntax+--  todo :: remove overloading /classes from Module (for TERM and CLAUSE)+--  for atom, overloading is probably ok+--  make seperate nonoverloaded functions for building terms.+-}++{-# LANGUAGE TypeSynonymInstances , FlexibleInstances, UndecidableInstances  #-}+{-# LANGUAGE OverlappingInstances #-}++module Language.Prolog.PrettyPrint.Direct++where++import Text.PrettyPrint+import Data.Char++renderProlog :: Doc -> String+renderProlog a = renderStyle (Style PageMode 60 1.5) a++newtype Atom = Atom {unAtom :: Doc}+newtype Term = Term {unTerm :: Doc}+newtype Predicate = Predicate {unPredicate :: Doc}+newtype Clause = Clause {unClause :: Doc}+newtype Decl = Decl {unDecl :: Doc}++newtype Quote = Quote String++class ATOM a where atom :: a -> Atom++instance ATOM Atom  where atom = id+instance ATOM String where atom = Atom . text . quoteString+instance ATOM Integer where atom = Atom . integer+instance ATOM Int where atom = Atom . int+instance ATOM Double where atom = Atom . double +instance ATOM Quote where atom (Quote s) = Atom $ text $ quoteString s++quoteString :: String -> String+quoteString a +  = "'"++(escapeQuote $ tail $ reverse $ tail $ reverse $ show a )++"'"+++class TERM t where term :: t -> Term++instance TERM Term where term = id+instance TERM Atom where term = Term . unAtom++class TERMLIST t where termList :: t -> [Term]+instance TERM t => TERMLIST [t]+  where termList = map term+instance (TERM t1,TERM t2) => TERMLIST (t1,t2)+  where termList (a,b) = [term a,term b]+instance (TERM t1,TERM t2,TERM t3) => TERMLIST (t1,t2,t3)+  where termList (a,b,c) = [term a,term b,term c]+instance (TERM t1,TERM t2,TERM t3,TERM t4) => TERMLIST (t1,t2,t3,t4)+  where termList (a,b,c,d) = [term a,term b,term c,term d]+instance (TERM t1,TERM t2,TERM t3,TERM t4,TERM t5) => TERMLIST (t1,t2,t3,t4,t5)+  where termList (a,b,c,d,e) = [term a,term b,term c,term d,term e]+instance (TERM t1,TERM t2,TERM t3,TERM t4,TERM t5,TERM t6) => TERMLIST (t1,t2,t3,t4,t5,t6)+  where termList (a,b,c,d,e,f) = [term a,term b,term c,term d,term e,term f]+instance (TERM t1,TERM t2,TERM t3,TERM t4,TERM t5,TERM t6,TERM t7)+  => TERMLIST (t1,t2,t3,t4,t5,t6,t7)+  where termList (a,b,c,d,e,f,g) = [term a,term b,term c,term d,term e,term f,term g]++{-+This is the default-case.+It overlapps all the other cases+-}+instance TERM t => TERMLIST t where termList a = [term a]++nTerm :: (ATOM f, TERMLIST ch) => f -> ch -> Term+nTerm f ch = Term $+  (unAtom $ atom f) <> if null childs+      then empty+      else parens $ hcat $ punctuate comma +                $ map ( unTerm . term ) childs+  where childs = termList ch++aTerm :: ATOM f => f -> Term+aTerm = Term . unAtom . atom++pList :: TERM ch => [ch] -> Term+pList l+  = Term $ brackets $ hcat +      $ punctuate comma $ map (unTerm . term )l++plVar  :: String -> Term+plVar [] = error "plVar : empty Sting"+plVar a@(h:_)+  = if isUpper h || h=='_'+      then Term $ text $ escapeBadChars a+      else error ("lowercase var:" ++ a)+        where+           escapeBadChars x = concatMap esc x+           esc '\'' = "_quote"+           esc x = [x]++plWildCard :: Term+plWildCard = Term $ text "_"++class PREDICATE p where predicate :: p -> Predicate+instance PREDICATE Predicate where predicate = id+instance TERM t => PREDICATE t where predicate = Predicate . unTerm . term++class CLAUSE c where clause :: c -> Clause+instance CLAUSE Clause where clause = id+instance PREDICATE p => CLAUSE p+  where clause x = Clause ( (unPredicate $ predicate x) <> text ".")+ +nClause :: (PREDICATE h, PREDICATE b) => h -> [b] -> Clause+nClause h b+  = Clause $ (unPredicate $ predicate h) <+> text ":-"+      $$ nest 3 (vcat $ punctuate comma $ map (unPredicate . predicate) b)+      <> text "."++singleClause :: Clause -> Decl+singleClause (Clause x) = Decl x++declGroup :: [Clause] -> Decl+declGroup l = Decl $ vcat $ map unClause l++plPrg :: [Decl] -> Doc+plPrg l = vcat $ map unDecl l++escapeQuote :: String -> String+escapeQuote x = concatMap escapeQ x+  where escapeQ '\'' = "\\'"+        escapeQ c = [c]