GF.Compile.PGFtoProlog

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