----------------------------------------------------------------------
-- |
-- Module      : GF.Speech.SISR
--
-- Abstract syntax and pretty printer for SISR,
-- (Semantic Interpretation for Speech Recognition)
----------------------------------------------------------------------
module GF.Speech.SISR (SISRFormat(..), SISRTag, prSISR, 
                       topCatSISR, profileInitSISR, catSISR, profileFinalSISR) where

import Data.List

--import GF.Data.Utilities
--import GF.Infra.Ident
import GF.Infra.Option (SISRFormat(..))
import GF.Grammar.CFG
import GF.Speech.SRG (SRGNT)
import PGF(showCId)

import qualified GF.JavaScript.AbsJS   as JS
import qualified GF.JavaScript.PrintJS as JS

type SISRTag = [JS.DeclOrExpr]


prSISR :: SISRTag -> String
prSISR :: SISRTag -> String
prSISR = SISRTag -> String
forall a. Print a => a -> String
JS.printTree

topCatSISR :: String -> SISRFormat -> SISRTag
topCatSISR :: String -> SISRFormat -> SISRTag
topCatSISR String
c SISRFormat
fmt = (Expr -> DeclOrExpr) -> [Expr] -> SISRTag
forall a b. (a -> b) -> [a] -> [b]
map Expr -> DeclOrExpr
JS.DExpr [SISRFormat -> Expr
fmtOut SISRFormat
fmt Expr -> Expr -> Expr
`ass` SISRFormat -> String -> Expr
fmtRef SISRFormat
fmt String
c]

profileInitSISR :: CFTerm -> SISRFormat -> SISRTag
profileInitSISR :: CFTerm -> SISRFormat -> SISRTag
profileInitSISR CFTerm
t SISRFormat
fmt 
    | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CFTerm -> [Int]
usedArgs CFTerm
t) = []
    | Bool
otherwise = [[DeclVar] -> DeclOrExpr
JS.Decl [Ident -> Expr -> DeclVar
JS.DInit Ident
args ([Expr] -> Expr
JS.EArray [])]]

usedArgs :: CFTerm -> [Int]
usedArgs :: CFTerm -> [Int]
usedArgs (CFObj CId
_ [CFTerm]
ts) = ([Int] -> [Int] -> [Int]) -> [Int] -> [[Int]] -> [Int]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
union [] ((CFTerm -> [Int]) -> [CFTerm] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map CFTerm -> [Int]
usedArgs [CFTerm]
ts)
usedArgs (CFAbs Int
_ CFTerm
x) = CFTerm -> [Int]
usedArgs CFTerm
x
usedArgs (CFApp CFTerm
x CFTerm
y) = CFTerm -> [Int]
usedArgs CFTerm
x [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
`union` CFTerm -> [Int]
usedArgs CFTerm
y
usedArgs (CFRes Int
i) = [Int
i]
usedArgs CFTerm
_ = []

catSISR :: CFTerm -> SRGNT -> SISRFormat -> SISRTag
catSISR :: CFTerm -> SRGNT -> SISRFormat -> SISRTag
catSISR CFTerm
t (String
c,Int
i) SISRFormat
fmt
        | Int
i Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` CFTerm -> [Int]
usedArgs CFTerm
t = (Expr -> DeclOrExpr) -> [Expr] -> SISRTag
forall a b. (a -> b) -> [a] -> [b]
map Expr -> DeclOrExpr
JS.DExpr 
            [Expr -> Expr -> Expr
JS.EIndex (Ident -> Expr
JS.EVar Ident
args) (Int -> Expr
JS.EInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)) Expr -> Expr -> Expr
`ass` SISRFormat -> String -> Expr
fmtRef SISRFormat
fmt String
c]
        | Bool
otherwise = []

profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
profileFinalSISR CFTerm
term SISRFormat
fmt = [Expr -> DeclOrExpr
JS.DExpr (Expr -> DeclOrExpr) -> Expr -> DeclOrExpr
forall a b. (a -> b) -> a -> b
$ SISRFormat -> Expr
fmtOut SISRFormat
fmt Expr -> Expr -> Expr
`ass` CFTerm -> Expr
f CFTerm
term]
  where 
        f :: CFTerm -> Expr
f (CFObj CId
n [CFTerm]
ts) = String -> [Expr] -> Expr
tree (CId -> String
showCId CId
n) ((CFTerm -> Expr) -> [CFTerm] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map CFTerm -> Expr
f [CFTerm]
ts)
        f (CFAbs Int
v CFTerm
x) = [Ident] -> [Stmt] -> Expr
JS.EFun [Int -> Ident
forall a. Show a => a -> Ident
var Int
v] [Expr -> Stmt
JS.SReturn (CFTerm -> Expr
f CFTerm
x)]
        f (CFApp CFTerm
x CFTerm
y) = Expr -> [Expr] -> Expr
JS.ECall (CFTerm -> Expr
f CFTerm
x) [CFTerm -> Expr
f CFTerm
y]
        f (CFRes Int
i) = Expr -> Expr -> Expr
JS.EIndex (Ident -> Expr
JS.EVar Ident
args) (Int -> Expr
JS.EInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
        f (CFVar Int
v) = Ident -> Expr
JS.EVar (Int -> Ident
forall a. Show a => a -> Ident
var Int
v)
        f (CFMeta CId
typ) = [(String, Expr)] -> Expr
obj [(String
"name",String -> Expr
JS.EStr String
"?"), (String
"type",String -> Expr
JS.EStr (CId -> String
showCId CId
typ))]

fmtOut :: SISRFormat -> Expr
fmtOut SISRFormat
SISR_WD20030401 = Ident -> Expr
JS.EVar (String -> Ident
JS.Ident String
"$")
fmtOut SISRFormat
SISR_1_0 = Ident -> Expr
JS.EVar (String -> Ident
JS.Ident String
"out")

fmtRef :: SISRFormat -> String -> Expr
fmtRef SISRFormat
SISR_WD20030401 String
c = Ident -> Expr
JS.EVar (String -> Ident
JS.Ident (String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c))
fmtRef SISRFormat
SISR_1_0 String
c = Expr -> String -> Expr
field (Ident -> Expr
JS.EVar (String -> Ident
JS.Ident String
"rules")) String
c

args :: Ident
args = String -> Ident
JS.Ident String
"a"

var :: a -> Ident
var a
v = String -> Ident
JS.Ident (String
"x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v)

field :: Expr -> String -> Expr
field Expr
x String
y = Expr -> Ident -> Expr
JS.EMember Expr
x (String -> Ident
JS.Ident String
y)

ass :: Expr -> Expr -> Expr
ass = Expr -> Expr -> Expr
JS.EAssign

tree :: String -> [Expr] -> Expr
tree String
n [Expr]
xs = [(String, Expr)] -> Expr
obj [(String
"name", String -> Expr
JS.EStr String
n), (String
"args", [Expr] -> Expr
JS.EArray [Expr]
xs)]

obj :: [(String, Expr)] -> Expr
obj [(String, Expr)]
ps = [Property] -> Expr
JS.EObj [PropertyName -> Expr -> Property
JS.Prop (String -> PropertyName
JS.StringPropName String
x) Expr
y | (String
x,Expr
y) <- [(String, Expr)]
ps]