module GF.Compile.PGFtoJS (pgf2js) where

import PGF(showCId)
import PGF.Internal as M
import qualified GF.JavaScript.AbsJS as JS
import qualified GF.JavaScript.PrintJS as JS

--import GF.Data.ErrM
--import GF.Infra.Option

--import Control.Monad (mplus)
--import Data.Array.Unboxed (UArray)
import qualified Data.Array.IArray as Array
--import Data.Maybe (fromMaybe)
import Data.Map (Map)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap

pgf2js :: PGF -> String
pgf2js :: PGF -> String
pgf2js PGF
pgf =
  Program -> String
forall a. Print a => a -> String
JS.printTree (Program -> String) -> Program -> String
forall a b. (a -> b) -> a -> b
$ [Element] -> Program
JS.Program [Stmt -> Element
JS.ElStmt (Stmt -> Element) -> Stmt -> Element
forall a b. (a -> b) -> a -> b
$ DeclOrExpr -> Stmt
JS.SDeclOrExpr (DeclOrExpr -> Stmt) -> DeclOrExpr -> Stmt
forall a b. (a -> b) -> a -> b
$ [DeclVar] -> DeclOrExpr
JS.Decl [Ident -> Expr -> DeclVar
JS.DInit (String -> Ident
JS.Ident String
n) Expr
grammar]]
 where
   n :: String
n  = CId -> String
showCId (CId -> String) -> CId -> String
forall a b. (a -> b) -> a -> b
$ PGF -> CId
absname PGF
pgf
   as :: Abstr
as = PGF -> Abstr
abstract PGF
pgf
   cs :: [(CId, Concr)]
cs = Map CId Concr -> [(CId, Concr)]
forall k a. Map k a -> [(k, a)]
Map.assocs (PGF -> Map CId Concr
concretes PGF
pgf)
   start :: String
start = CId -> String
showCId (CId -> String) -> CId -> String
forall a b. (a -> b) -> a -> b
$ PGF -> CId
M.lookStartCat PGF
pgf
   grammar :: Expr
grammar = String -> [Expr] -> Expr
new String
"GFGrammar" [Expr
js_abstract, Expr
js_concrete]
   js_abstract :: Expr
js_abstract = String -> Abstr -> Expr
abstract2js String
start Abstr
as
   js_concrete :: Expr
js_concrete = [Property] -> Expr
JS.EObj ([Property] -> Expr) -> [Property] -> Expr
forall a b. (a -> b) -> a -> b
$ ((CId, Concr) -> Property) -> [(CId, Concr)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (CId, Concr) -> Property
concrete2js [(CId, Concr)]
cs

abstract2js :: String -> Abstr -> JS.Expr
abstract2js :: String -> Abstr -> Expr
abstract2js String
start Abstr
ds = String -> [Expr] -> Expr
new String
"GFAbstract" [String -> Expr
JS.EStr String
start, [Property] -> Expr
JS.EObj ([Property] -> Expr) -> [Property] -> Expr
forall a b. (a -> b) -> a -> b
$ ((CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
 -> Property)
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
-> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Property
absdef2js (Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
forall k a. Map k a -> [(k, a)]
Map.assocs (Abstr -> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Abstr
ds))]

absdef2js :: (CId,(Type,Int,Maybe ([Equation],[[M.Instr]]),Double)) -> JS.Property
absdef2js :: (CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))
-> Property
absdef2js (CId
f,(Type
typ,Int
_,Maybe ([Equation], [[Instr]])
_,Double
_)) =
  let ([CId]
args,CId
cat) = Type -> ([CId], CId)
M.catSkeleton Type
typ in 
    PropertyName -> Expr -> Property
JS.Prop (Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident (CId -> String
showCId CId
f))) (String -> [Expr] -> Expr
new String
"Type" [[Expr] -> Expr
JS.EArray [String -> Expr
JS.EStr (CId -> String
showCId CId
x) | CId
x <- [CId]
args], String -> Expr
JS.EStr (CId -> String
showCId CId
cat)])

lit2js :: Literal -> Expr
lit2js (LStr String
s) = String -> Expr
JS.EStr String
s
lit2js (LInt Int
n) = Int -> Expr
JS.EInt Int
n
lit2js (LFlt Double
d) = Double -> Expr
JS.EDbl Double
d

concrete2js :: (CId,Concr) -> JS.Property
concrete2js :: (CId, Concr) -> Property
concrete2js (CId
c,Concr
cnc) =
  PropertyName -> Expr -> Property
JS.Prop PropertyName
l (String -> [Expr] -> Expr
new String
"GFConcrete" [(Literal -> Expr) -> Map CId Literal -> Expr
forall a. (a -> Expr) -> Map CId a -> Expr
mapToJSObj (Literal -> Expr
lit2js) (Map CId Literal -> Expr) -> Map CId Literal -> Expr
forall a b. (a -> b) -> a -> b
$ Concr -> Map CId Literal
cflags Concr
cnc,
                               [Property] -> Expr
JS.EObj ([Property] -> Expr) -> [Property] -> Expr
forall a b. (a -> b) -> a -> b
$ [PropertyName -> Expr -> Property
JS.Prop (Int -> PropertyName
JS.IntPropName Int
cat) ([Expr] -> Expr
JS.EArray ((Production -> Expr) -> [Production] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Production -> Expr
frule2js (Set Production -> [Production]
forall a. Set a -> [a]
Set.toList Set Production
set))) | (Int
cat,Set Production
set) <- IntMap (Set Production) -> [(Int, Set Production)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (Concr -> IntMap (Set Production)
productions Concr
cnc)],
                               [Expr] -> Expr
JS.EArray ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ ((CncFun -> Expr) -> [CncFun] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map CncFun -> Expr
ffun2js (Array Int CncFun -> [CncFun]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems (Concr -> Array Int CncFun
cncfuns Concr
cnc))),
                               [Expr] -> Expr
JS.EArray ([Expr] -> Expr) -> [Expr] -> Expr
forall a b. (a -> b) -> a -> b
$ ((Array Int Symbol -> Expr) -> [Array Int Symbol] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Array Int Symbol -> Expr
seq2js (Array Int (Array Int Symbol) -> [Array Int Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems (Concr -> Array Int (Array Int Symbol)
sequences Concr
cnc))),
                               [Property] -> Expr
JS.EObj ([Property] -> Expr) -> [Property] -> Expr
forall a b. (a -> b) -> a -> b
$ ((CId, CncCat) -> Property) -> [(CId, CncCat)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (CId, CncCat) -> Property
cats (Map CId CncCat -> [(CId, CncCat)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Concr -> Map CId CncCat
cnccats Concr
cnc)),
                               Int -> Expr
JS.EInt (Concr -> Int
totalCats Concr
cnc)])
  where 
   l :: PropertyName
l  = Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident (CId -> String
showCId CId
c))
{-
   litslins = [JS.Prop (JS.StringPropName    "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), 
               JS.Prop (JS.StringPropName  "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
               JS.Prop (JS.StringPropName "String") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]])]
-}
   cats :: (CId, CncCat) -> Property
cats (CId
c,CncCat Int
start Int
end Array Int String
_) = PropertyName -> Expr -> Property
JS.Prop (Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident (CId -> String
showCId CId
c))) ([Property] -> Expr
JS.EObj [PropertyName -> Expr -> Property
JS.Prop (Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident String
"s")) (Int -> Expr
JS.EInt Int
start)
                                                                                            ,PropertyName -> Expr -> Property
JS.Prop (Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident String
"e")) (Int -> Expr
JS.EInt Int
end)])
{-
mkStr :: String -> JS.Expr
mkStr s = new "Str" [JS.EStr s]

mkSeq :: [JS.Expr] -> JS.Expr
mkSeq [x] = x
mkSeq xs = new "Seq" xs

argIdent :: Integer -> JS.Ident
argIdent n = JS.Ident ("x" ++ show n)
-}
children :: JS.Ident
children :: Ident
children = String -> Ident
JS.Ident String
"cs"

frule2js :: Production -> JS.Expr
frule2js :: Production -> Expr
frule2js (PApply Int
funid [PArg]
args) = String -> [Expr] -> Expr
new String
"Apply"  [Int -> Expr
JS.EInt Int
funid, [Expr] -> Expr
JS.EArray ((PArg -> Expr) -> [PArg] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> Expr
farg2js [PArg]
args)]
frule2js (PCoerce Int
arg)       = String -> [Expr] -> Expr
new String
"Coerce" [Int -> Expr
JS.EInt Int
arg]

farg2js :: PArg -> Expr
farg2js (PArg [(Int, Int)]
hypos Int
fid) = String -> [Expr] -> Expr
new String
"PArg" (((Int, Int) -> Expr) -> [(Int, Int)] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Expr
JS.EInt (Int -> Expr) -> ((Int, Int) -> Int) -> (Int, Int) -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd) [(Int, Int)]
hypos [Expr] -> [Expr] -> [Expr]
forall a. [a] -> [a] -> [a]
++ [Int -> Expr
JS.EInt Int
fid])

ffun2js :: CncFun -> Expr
ffun2js (CncFun CId
f UArray Int Int
lins) = String -> [Expr] -> Expr
new String
"CncFun" [String -> Expr
JS.EStr (CId -> String
showCId CId
f), [Expr] -> Expr
JS.EArray ((Int -> Expr) -> [Int] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Expr
JS.EInt (UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems UArray Int Int
lins))]

seq2js :: Array.Array DotPos Symbol -> JS.Expr
seq2js :: Array Int Symbol -> Expr
seq2js Array Int Symbol
seq = [Expr] -> Expr
JS.EArray [Symbol -> Expr
sym2js Symbol
s | Symbol
s <- Array Int Symbol -> [Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
Array.elems Array Int Symbol
seq]

sym2js :: Symbol -> JS.Expr
sym2js :: Symbol -> Expr
sym2js (SymCat Int
n Int
l)    = String -> [Expr] -> Expr
new String
"SymCat" [Int -> Expr
JS.EInt Int
n, Int -> Expr
JS.EInt Int
l]
sym2js (SymLit Int
n Int
l)    = String -> [Expr] -> Expr
new String
"SymLit" [Int -> Expr
JS.EInt Int
n, Int -> Expr
JS.EInt Int
l]
sym2js (SymVar Int
n Int
l)    = String -> [Expr] -> Expr
new String
"SymVar" [Int -> Expr
JS.EInt Int
n, Int -> Expr
JS.EInt Int
l]
sym2js (SymKS String
t)       = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
t]
sym2js (SymKP [Symbol]
ts [([Symbol], [String])]
alts) = String -> [Expr] -> Expr
new String
"SymKP"  [[Expr] -> Expr
JS.EArray ((Symbol -> Expr) -> [Symbol] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Expr
sym2js [Symbol]
ts), [Expr] -> Expr
JS.EArray ((([Symbol], [String]) -> Expr) -> [([Symbol], [String])] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ([Symbol], [String]) -> Expr
alt2js [([Symbol], [String])]
alts)]
sym2js Symbol
SymBIND         = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
"&+"]
sym2js Symbol
SymSOFT_BIND    = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
"&+"]
sym2js Symbol
SymSOFT_SPACE   = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
"&+"]
sym2js Symbol
SymCAPIT        = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
"&|"]
sym2js Symbol
SymALL_CAPIT    = String -> [Expr] -> Expr
new String
"SymKS"  [String -> Expr
JS.EStr String
"&|"]
sym2js Symbol
SymNE           = String -> [Expr] -> Expr
new String
"SymNE"  []

alt2js :: ([Symbol], [String]) -> Expr
alt2js ([Symbol]
ps,[String]
ts) = String -> [Expr] -> Expr
new String
"Alt" [[Expr] -> Expr
JS.EArray ((Symbol -> Expr) -> [Symbol] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map Symbol -> Expr
sym2js [Symbol]
ps), [Expr] -> Expr
JS.EArray ((String -> Expr) -> [String] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
JS.EStr [String]
ts)]

new :: String -> [JS.Expr] -> JS.Expr
new :: String -> [Expr] -> Expr
new String
f [Expr]
xs = Ident -> [Expr] -> Expr
JS.ENew (String -> Ident
JS.Ident String
f) [Expr]
xs

mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
mapToJSObj :: (a -> Expr) -> Map CId a -> Expr
mapToJSObj a -> Expr
f Map CId a
m = [Property] -> Expr
JS.EObj [ PropertyName -> Expr -> Property
JS.Prop (Ident -> PropertyName
JS.IdentPropName (String -> Ident
JS.Ident (CId -> String
showCId CId
k))) (a -> Expr
f a
v) | (CId
k,a
v) <- Map CId a -> [(CId, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CId a
m ]