forked from GitHub/gf-core
584d589041
The def rules are now compiled to byte code by the compiler and then to native code by the JIT compiler in the runtime. Not all constructions are implemented yet. The partial implementation is now in the repository but it is not activated by default since this requires changes in the PGF format. I will enable it only after it is complete.
263 lines
10 KiB
Haskell
263 lines
10 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : PGFtoProlog
|
|
-- Maintainer : Peter Ljunglöf
|
|
--
|
|
-- exports a GF grammar into a Prolog module
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Compile.PGFtoProlog (grammar2prolog) where
|
|
|
|
import PGF(mkCId,wildCId,showCId)
|
|
import PGF.Internal
|
|
--import PGF.Macros
|
|
|
|
import GF.Data.Operations
|
|
|
|
import qualified Data.Array.IArray as Array
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.IntMap as IntMap
|
|
import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, ord)
|
|
import Data.List (isPrefixOf, mapAccumL)
|
|
|
|
grammar2prolog :: PGF -> String
|
|
grammar2prolog pgf
|
|
= ("%% This file was automatically generated by GF" +++++
|
|
":- style_check(-singleton)." +++++
|
|
plFacts wildCId "abstract" 1 "(?AbstractName)"
|
|
[[plp name]] ++++
|
|
plFacts wildCId "concrete" 2 "(?AbstractName, ?ConcreteName)"
|
|
[[plp name, plp cncname] |
|
|
cncname <- Map.keys (concretes pgf)] ++++
|
|
plFacts wildCId "flag" 2 "(?Flag, ?Value): global flags"
|
|
[[plp f, plp v] |
|
|
(f, v) <- Map.assocs (gflags pgf)] ++++
|
|
plAbstract name (abstract pgf) ++++
|
|
unlines (map plConcrete (Map.assocs (concretes pgf)))
|
|
)
|
|
where name = absname pgf
|
|
|
|
----------------------------------------------------------------------
|
|
-- abstract syntax
|
|
|
|
plAbstract :: CId -> Abstr -> String
|
|
plAbstract name abs
|
|
= (plHeader "Abstract syntax" ++++
|
|
plFacts name "flag" 2 "(?Flag, ?Value): flags for abstract syntax"
|
|
[[plp f, plp v] |
|
|
(f, v) <- Map.assocs (aflags abs)] ++++
|
|
plFacts name "cat" 2 "(?Type, ?[X:Type,...])"
|
|
[[plType cat args, plHypos hypos'] |
|
|
(cat, (hypos,_,_)) <- Map.assocs (cats abs),
|
|
let ((_, subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos,
|
|
let args = reverse [EFun x | (_,x) <- subst]] ++++
|
|
plFacts name "fun" 3 "(?Fun, ?Type, ?[X:Type,...])"
|
|
[[plp fun, plType cat args, plHypos hypos] |
|
|
(fun, (typ, _, _, _)) <- Map.assocs (funs abs),
|
|
let (_, DTyp hypos cat args) = alphaConvert emptyEnv typ] ++++
|
|
plFacts name "def" 2 "(?Fun, ?Expr)"
|
|
[[plp fun, plp expr] |
|
|
(fun, (_, _, Just (eqs,_), _)) <- Map.assocs (funs abs),
|
|
let (_, expr) = alphaConvert emptyEnv eqs]
|
|
)
|
|
where plType cat args = plTerm (plp cat) (map plp args)
|
|
plHypos hypos = plList [plOper ":" (plp x) (plp ty) | (_, x, ty) <- hypos]
|
|
|
|
----------------------------------------------------------------------
|
|
-- concrete syntax
|
|
|
|
plConcrete :: (CId, Concr) -> String
|
|
plConcrete (name, cnc)
|
|
= (plHeader ("Concrete syntax: " ++ plp name) ++++
|
|
plFacts name "flag" 2 "(?Flag, ?Value): flags for concrete syntax"
|
|
[[plp f, plp v] |
|
|
(f, v) <- Map.assocs (cflags cnc)] ++++
|
|
plFacts name "printname" 2 "(?AbsFun/AbsCat, ?Atom)"
|
|
[[plp f, plp n] |
|
|
(f, n) <- Map.assocs (printnames cnc)] ++++
|
|
plFacts name "lindef" 2 "(?CncCat, ?CncFun)"
|
|
[[plCat cat, plFun fun] |
|
|
(cat, funs) <- IntMap.assocs (lindefs cnc),
|
|
fun <- funs] ++++
|
|
plFacts name "prod" 3 "(?CncCat, ?CncFun, ?[CncCat])"
|
|
[[plCat cat, fun, plTerm "c" (map plCat args)] |
|
|
(cat, set) <- IntMap.toList (productions cnc),
|
|
(fun, args) <- map plProduction (Set.toList set)] ++++
|
|
plFacts name "cncfun" 3 "(?CncFun, ?[Seq,...], ?AbsFun)"
|
|
[[plFun fun, plTerm "s" (map plSeq (Array.elems lins)), plp absfun] |
|
|
(fun, CncFun absfun lins) <- Array.assocs (cncfuns cnc)] ++++
|
|
plFacts name "seq" 2 "(?Seq, ?[Term])"
|
|
[[plSeq seq, plp (Array.elems symbols)] |
|
|
(seq, symbols) <- Array.assocs (sequences cnc)] ++++
|
|
plFacts name "cnccat" 2 "(?AbsCat, ?[CnCCat])"
|
|
[[plp cat, plList (map plCat [start..end])] |
|
|
(cat, CncCat start end _) <- Map.assocs (cnccats cnc)]
|
|
)
|
|
where plProduction (PCoerce arg) = ("-", [arg])
|
|
plProduction (PApply funid args) = (plFun funid, [fid | PArg hypos fid <- args])
|
|
|
|
----------------------------------------------------------------------
|
|
-- prolog-printing pgf datatypes
|
|
|
|
instance PLPrint Type where
|
|
plp (DTyp hypos cat args)
|
|
| null hypos = result
|
|
| otherwise = plOper " -> " plHypos result
|
|
where result = plTerm (plp cat) (map plp args)
|
|
plHypos = plList [plOper ":" (plp x) (plp ty) | (_,x,ty) <- hypos]
|
|
|
|
instance PLPrint Expr where
|
|
plp (EFun x) = plp x
|
|
plp (EAbs _ x e)= plOper "^" (plp x) (plp e)
|
|
plp (EApp e e') = plOper " * " (plp e) (plp e')
|
|
plp (ELit lit) = plp lit
|
|
plp (EMeta n) = "Meta_" ++ show n
|
|
|
|
instance PLPrint Patt where
|
|
plp (PVar x) = plp x
|
|
plp (PApp f ps) = plOper " * " (plp f) (plp ps)
|
|
plp (PLit lit) = plp lit
|
|
|
|
instance PLPrint Equation where
|
|
plp (Equ patterns result) = plOper ":" (plp patterns) (plp result)
|
|
|
|
instance PLPrint CId where
|
|
plp cid | isLogicalVariable str || cid == wildCId = plVar str
|
|
| otherwise = plAtom str
|
|
where str = showCId cid
|
|
|
|
instance PLPrint Literal where
|
|
plp (LStr s) = plp s
|
|
plp (LInt n) = plp (show n)
|
|
plp (LFlt f) = plp (show f)
|
|
|
|
instance PLPrint Symbol where
|
|
plp (SymCat n l) = plOper ":" (show n) (show l)
|
|
plp (SymLit n l) = plTerm "lit" [show n, show l]
|
|
plp (SymVar n l) = plTerm "var" [show n, show l]
|
|
plp (SymKS t) = plAtom t
|
|
plp (SymKP ts alts) = plTerm "pre" [plList (map plp ts), plList (map plAlt alts)]
|
|
where plAlt (ps,ts) = plOper "/" (plList (map plp ps)) (plList (map plAtom ts))
|
|
|
|
class PLPrint a where
|
|
plp :: a -> String
|
|
plps :: [a] -> String
|
|
plps = plList . map plp
|
|
|
|
instance PLPrint Char where
|
|
plp c = plAtom [c]
|
|
plps s = plAtom s
|
|
|
|
instance PLPrint a => PLPrint [a] where
|
|
plp = plps
|
|
|
|
----------------------------------------------------------------------
|
|
-- other prolog-printing functions
|
|
|
|
plCat :: Int -> String
|
|
plCat n = plAtom ('c' : show n)
|
|
|
|
plFun :: Int -> String
|
|
plFun n = plAtom ('f' : show n)
|
|
|
|
plSeq :: Int -> String
|
|
plSeq n = plAtom ('s' : show n)
|
|
|
|
plHeader :: String -> String
|
|
plHeader hdr = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n%% " ++ hdr ++ "\n"
|
|
|
|
plFacts :: CId -> String -> Int -> String -> [[String]] -> String
|
|
plFacts mod pred arity comment facts = "%% " ++ pred ++ comment ++++ clauses
|
|
where clauses = (if facts == [] then ":- dynamic " ++ pred ++ "/" ++ show arity ++ ".\n"
|
|
else unlines [mod' ++ plTerm pred args ++ "." | args <- facts])
|
|
mod' = if mod == wildCId then "" else plp mod ++ ": "
|
|
|
|
plTerm :: String -> [String] -> String
|
|
plTerm fun args = plAtom fun ++ prParenth (prTList ", " args)
|
|
|
|
plList :: [String] -> String
|
|
plList xs = prBracket (prTList "," xs)
|
|
|
|
plOper :: String -> String -> String -> String
|
|
plOper op a b = prParenth (a ++ op ++ b)
|
|
|
|
plVar :: String -> String
|
|
plVar = varPrefix . concatMap changeNonAlphaNum
|
|
where varPrefix var@(c:_) | isAsciiUpper c || c=='_' = var
|
|
| otherwise = "_" ++ var
|
|
changeNonAlphaNum c | isAlphaNumUnderscore c = [c]
|
|
| otherwise = "_" ++ show (ord c) ++ "_"
|
|
|
|
plAtom :: String -> String
|
|
plAtom "" = "''"
|
|
plAtom atom@(c:cs) | isAsciiLower c && all isAlphaNumUnderscore cs
|
|
|| c == '\'' && cs /= "" && last cs == '\'' = atom
|
|
| otherwise = "'" ++ changeQuote atom ++ "'"
|
|
where changeQuote ('\'':cs) = '\\' : '\'' : changeQuote cs
|
|
changeQuote ('\\':cs) = '\\' : '\\' : changeQuote cs
|
|
changeQuote (c:cs) = c : changeQuote cs
|
|
changeQuote "" = ""
|
|
|
|
isAlphaNumUnderscore :: Char -> Bool
|
|
isAlphaNumUnderscore c = (isAscii c && isAlphaNum c) || c == '_'
|
|
|
|
----------------------------------------------------------------------
|
|
-- prolog variables
|
|
|
|
createLogicalVariable :: Int -> CId
|
|
createLogicalVariable n = mkCId (logicalVariablePrefix ++ show n)
|
|
|
|
isLogicalVariable :: String -> Bool
|
|
isLogicalVariable = isPrefixOf logicalVariablePrefix
|
|
|
|
logicalVariablePrefix :: String
|
|
logicalVariablePrefix = "X"
|
|
|
|
----------------------------------------------------------------------
|
|
-- alpha convert variables to (unique) logical variables
|
|
-- * this is needed if we want to translate variables to Prolog variables
|
|
-- * used for abstract syntax, not concrete
|
|
-- * not (yet?) used for variables bound in pattern equations
|
|
|
|
type ConvertEnv = (Int, [(CId,CId)])
|
|
|
|
emptyEnv :: ConvertEnv
|
|
emptyEnv = (0, [])
|
|
|
|
class AlphaConvert a where
|
|
alphaConvert :: ConvertEnv -> a -> (ConvertEnv, a)
|
|
|
|
instance AlphaConvert a => AlphaConvert [a] where
|
|
alphaConvert env [] = (env, [])
|
|
alphaConvert env (a:as) = (env'', a':as')
|
|
where (env', a') = alphaConvert env a
|
|
(env'', as') = alphaConvert env' as
|
|
|
|
instance AlphaConvert Type where
|
|
alphaConvert env@(_,subst) (DTyp hypos cat args)
|
|
= ((ctr,subst), DTyp hypos' cat args')
|
|
where (env', hypos') = mapAccumL alphaConvertHypo env hypos
|
|
((ctr,_), args') = alphaConvert env' args
|
|
|
|
alphaConvertHypo env (b,x,typ) = ((ctr+1,(x,x'):subst), (b,x',typ'))
|
|
where ((ctr,subst), typ') = alphaConvert env typ
|
|
x' = createLogicalVariable ctr
|
|
|
|
instance AlphaConvert Expr where
|
|
alphaConvert (ctr,subst) (EAbs b x e) = ((ctr',subst), EAbs b x' e')
|
|
where ((ctr',_), e') = alphaConvert (ctr+1,(x,x'):subst) e
|
|
x' = createLogicalVariable ctr
|
|
alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
|
|
where (env', e1') = alphaConvert env e1
|
|
(env'', e2') = alphaConvert env' e2
|
|
alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
|
|
alphaConvert env expr = (env, expr)
|
|
|
|
-- pattern variables are not alpha converted
|
|
-- (but they probably should be...)
|
|
instance AlphaConvert Equation where
|
|
alphaConvert env@(_,subst) (Equ patterns result)
|
|
= ((ctr,subst), Equ patterns result')
|
|
where ((ctr,_), result') = alphaConvert env result
|