content: ----------------------------------------------------------------------
  -- |
  -- 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
  