mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 05:49:31 -06:00
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.CId
|
|
import PGF.Data
|
|
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 ts) = prTList "," (map plAtom ts)
|
|
plp (SymKP ts alts) = plTerm "pre" [plList (map plAtom ts), plList (map plAlt alts)]
|
|
where plAlt (Alt ps ts) = plOper "/" (plList (map plAtom 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
|