mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
new GFCC concrete syntax in place everywhere
This commit is contained in:
aarne
@@ -21,8 +21,10 @@ import qualified GF.Canon.Look as Look
|
||||
import qualified GF.Canon.Subexpressions as Sub
|
||||
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import GF.Devel.PrintGFCC
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
|
||||
import GF.Canon.GFC
|
||||
@@ -46,7 +48,7 @@ import Debug.Trace ----
|
||||
-- the main function: generate GFCC from GFCM.
|
||||
|
||||
prCanon2gfcc :: CanonGrammar -> String
|
||||
prCanon2gfcc = D.printGFCC . mkCanon2gfcc
|
||||
prCanon2gfcc = printGFCC . mkCanon2gfcc
|
||||
|
||||
-- this variant makes utf8 conversion; used in back ends
|
||||
mkCanon2gfcc :: CanonGrammar -> D.GFCC
|
||||
@@ -99,8 +101,8 @@ canon2gfcc cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
||||
printnames = Map.fromAscList [] ---- printnames
|
||||
params = Map.fromAscList [] ---- params
|
||||
|
||||
i2i :: Ident -> C.CId
|
||||
i2i (IC c) = C.CId c
|
||||
i2i :: Ident -> CId
|
||||
i2i (IC c) = CId c
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.catSkeleton t of
|
||||
|
||||
@@ -7,7 +7,8 @@ import GF.Data.ErrM
|
||||
import GF.Infra.Option
|
||||
import qualified GF.GFCC.Macros as M
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId(CId))
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
@@ -32,28 +33,28 @@ gfcc2js start gfcc =
|
||||
as = D.abstract gfcc
|
||||
cs = Map.assocs (D.concretes gfcc)
|
||||
|
||||
abstract2js :: String -> C.CId -> D.Abstr -> [JS.Element]
|
||||
abstract2js start (C.CId n) ds =
|
||||
abstract2js :: String -> CId -> D.Abstr -> [JS.Element]
|
||||
abstract2js start (CId n) ds =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]]
|
||||
++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
|
||||
where a = JS.Ident n
|
||||
|
||||
absdef2js :: JS.Ident -> (C.CId,(C.Type,C.Exp)) -> [JS.Element]
|
||||
absdef2js a (C.CId f,(typ,_)) =
|
||||
let (args,C.CId cat) = M.catSkeleton typ in
|
||||
absdef2js :: JS.Ident -> (CId,(C.Type,C.Exp)) -> [JS.Element]
|
||||
absdef2js a (CId f,(typ,_)) =
|
||||
let (args,CId cat) = M.catSkeleton typ in
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType"))
|
||||
[JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]]
|
||||
[JS.EStr f, JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]]
|
||||
|
||||
concrete2js :: C.CId -> (C.CId,D.Concr) -> [JS.Element]
|
||||
concrete2js (C.CId a) (C.CId c, cnc) =
|
||||
concrete2js :: CId -> (CId,D.Concr) -> [JS.Element]
|
||||
concrete2js (CId a) (CId c, cnc) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]]
|
||||
++ concatMap (cncdef2js l) ds
|
||||
where
|
||||
l = JS.Ident c
|
||||
ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
|
||||
|
||||
cncdef2js :: JS.Ident -> (C.CId,C.Term) -> [JS.Element]
|
||||
cncdef2js l (C.CId f, t) =
|
||||
cncdef2js :: JS.Ident -> (CId,C.Term) -> [JS.Element]
|
||||
cncdef2js l (CId f, t) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
|
||||
|
||||
term2js :: JS.Ident -> C.Term -> JS.Expr
|
||||
@@ -67,7 +68,7 @@ term2js l t = f t
|
||||
C.K t -> tokn2js t
|
||||
C.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
C.C i -> new "Int" [JS.EInt i]
|
||||
C.F (C.CId f) -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
|
||||
C.F (CId f) -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
|
||||
C.FV xs -> new "Variants" (map f xs)
|
||||
C.W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
C.RP x y -> new "Rp" [f x, f y]
|
||||
|
||||
@@ -16,7 +16,7 @@ import GF.GFCC.ShowLinearize
|
||||
import GF.GFCC.API
|
||||
import GF.GFCC.Macros
|
||||
import GF.Devel.PrintGFCC
|
||||
import GF.GFCC.AbsGFCC ----
|
||||
import GF.GFCC.DataGFCC ----
|
||||
|
||||
import GF.Command.ErrM ----
|
||||
|
||||
|
||||
@@ -5,7 +5,6 @@ import GF.Devel.GrammarToGFCC
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
import GF.GFCC.CheckGFCC
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.ParGFCC
|
||||
import GF.GFCC.API
|
||||
import qualified GF.Command.AbsGFShell as C
|
||||
|
||||
|
||||
@@ -9,7 +9,7 @@ import GF.Command.PPrTree
|
||||
import GF.Command.ParGFShell
|
||||
import GF.GFCC.API
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.AbsGFCC ----
|
||||
import GF.GFCC.DataGFCC
|
||||
|
||||
import GF.Command.ErrM ----
|
||||
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
module GF.Command.PPrTree (pTree, prExp, tree2exp) where
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Macros
|
||||
import qualified GF.Command.ParGFShell as P
|
||||
import GF.Command.PrintGFShell
|
||||
|
||||
@@ -17,7 +17,7 @@ module GF.Compile.ShellState where
|
||||
import GF.Data.Operations
|
||||
import GF.Canon.GFC
|
||||
import GF.Canon.AbsGFC
|
||||
import GF.GFCC.AbsGFCC(CId(CId))
|
||||
import GF.GFCC.Raw.AbsGFCCRaw(CId(CId))
|
||||
--import GF.GFCC.DataGFCC(mkGFCC)
|
||||
import GF.Canon.CanonToGFCC as C2GFCC
|
||||
import GF.Grammar.Macros
|
||||
|
||||
@@ -22,9 +22,9 @@ import Control.Monad
|
||||
import GF.Formalism.Utilities
|
||||
import GF.Formalism.FCFG
|
||||
|
||||
import GF.GFCC.Macros hiding (prt)
|
||||
import GF.GFCC.Macros --hiding (prt)
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
|
||||
import GF.Data.BacktrackM
|
||||
import GF.Data.SortedList
|
||||
|
||||
@@ -18,7 +18,7 @@ module GF.Conversion.Types where
|
||||
|
||||
import qualified GF.Infra.Ident as Ident (Ident(..), wildIdent, isWildIdent)
|
||||
import qualified GF.Canon.AbsGFC as AbsGFC (CIdent(..), Label(..))
|
||||
import qualified GF.GFCC.AbsGFCC as AbsGFCC (CId(..))
|
||||
import qualified GF.GFCC.Raw.AbsGFCCRaw as AbsGFCC (CId(..))
|
||||
import qualified GF.Grammar.Grammar as Grammar (Term)
|
||||
|
||||
import GF.Formalism.GCFG
|
||||
|
||||
@@ -7,9 +7,11 @@ import GF.Devel.GrammarToGFCC
|
||||
import GF.GFCC.OptimizeGFCC
|
||||
import GF.GFCC.CheckGFCC
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.ParGFCC
|
||||
import GF.GFCC.Raw.ParGFCCRaw
|
||||
import GF.GFCC.Raw.ConvertGFCC
|
||||
import GF.Devel.UseIO
|
||||
import GF.Infra.Option
|
||||
import GF.GFCC.API
|
||||
import GF.GFCC.ErrM
|
||||
|
||||
mainGFC :: [String] -> IO ()
|
||||
@@ -44,12 +46,6 @@ mainGFC xx = do
|
||||
mapM_ (batchCompile opts) (map return fs)
|
||||
putStrLn "Done."
|
||||
|
||||
file2gfcc f = do
|
||||
f <- readFileIf f
|
||||
case pGrammar (myLexer f) of
|
||||
Ok g -> return (mkGFCC g)
|
||||
Bad s -> error s
|
||||
|
||||
targetName opts abs = case getOptVal opts (aOpt "target") of
|
||||
Just n -> n
|
||||
_ -> abs
|
||||
|
||||
@@ -18,7 +18,7 @@ module GF.Devel.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where
|
||||
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
|
||||
import GF.Data.Operations
|
||||
import GF.Text.UTF8
|
||||
|
||||
@@ -2,7 +2,7 @@ module GF.Devel.GFCCtoJS (gfcc2js,gfcc2grammarRef) where
|
||||
|
||||
import qualified GF.GFCC.Macros as M
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import qualified GF.JavaScript.AbsJS as JS
|
||||
import qualified GF.JavaScript.PrintJS as JS
|
||||
|
||||
@@ -24,50 +24,50 @@ gfcc2js gfcc =
|
||||
cs = Map.assocs (D.concretes gfcc)
|
||||
start = M.lookAbsFlag gfcc (M.cid "startcat")
|
||||
|
||||
abstract2js :: String -> C.CId -> D.Abstr -> [JS.Element]
|
||||
abstract2js start (C.CId n) ds =
|
||||
abstract2js :: String -> CId -> D.Abstr -> [JS.Element]
|
||||
abstract2js start (CId n) ds =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit a (new "Abstract" [JS.EStr start])]]
|
||||
++ concatMap (absdef2js a) (Map.assocs (D.funs ds))
|
||||
where a = JS.Ident n
|
||||
|
||||
absdef2js :: JS.Ident -> (C.CId,(C.Type,C.Exp)) -> [JS.Element]
|
||||
absdef2js a (C.CId f,(typ,_)) =
|
||||
let (args,C.CId cat) = M.catSkeleton typ in
|
||||
absdef2js :: JS.Ident -> (CId,(D.Type,D.Exp)) -> [JS.Element]
|
||||
absdef2js a (CId f,(typ,_)) =
|
||||
let (args,CId cat) = M.catSkeleton typ in
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar a) (JS.Ident "addType"))
|
||||
[JS.EStr f, JS.EArray [JS.EStr x | C.CId x <- args], JS.EStr cat]]
|
||||
[JS.EStr f, JS.EArray [JS.EStr x | CId x <- args], JS.EStr cat]]
|
||||
|
||||
concrete2js :: C.CId -> (C.CId,D.Concr) -> [JS.Element]
|
||||
concrete2js (C.CId a) (C.CId c, cnc) =
|
||||
concrete2js :: CId -> (CId,D.Concr) -> [JS.Element]
|
||||
concrete2js (CId a) (CId c, cnc) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit l (new "Concrete" [JS.EVar (JS.Ident a)])]]
|
||||
++ concatMap (cncdef2js l) ds
|
||||
where
|
||||
l = JS.Ident c
|
||||
ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc]
|
||||
|
||||
cncdef2js :: JS.Ident -> (C.CId,C.Term) -> [JS.Element]
|
||||
cncdef2js l (C.CId f, t) =
|
||||
cncdef2js :: JS.Ident -> (CId,D.Term) -> [JS.Element]
|
||||
cncdef2js l (CId f, t) =
|
||||
[JS.ElStmt $ JS.SDeclOrExpr $ JS.DExpr $ JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "addRule")) [JS.EStr f, JS.EFun [children] [JS.SReturn (term2js l t)]]]
|
||||
|
||||
term2js :: JS.Ident -> C.Term -> JS.Expr
|
||||
term2js :: JS.Ident -> D.Term -> JS.Expr
|
||||
term2js l t = f t
|
||||
where
|
||||
f t =
|
||||
case t of
|
||||
C.R xs -> new "Arr" (map f xs)
|
||||
C.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
C.S xs -> mkSeq (map f xs)
|
||||
C.K t -> tokn2js t
|
||||
C.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
C.C i -> new "Int" [JS.EInt i]
|
||||
C.F (C.CId f) -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
|
||||
C.FV xs -> new "Variants" (map f xs)
|
||||
C.W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
C.RP x y -> new "Rp" [f x, f y]
|
||||
C.TM -> new "Meta" []
|
||||
D.R xs -> new "Arr" (map f xs)
|
||||
D.P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y]
|
||||
D.S xs -> mkSeq (map f xs)
|
||||
D.K t -> tokn2js t
|
||||
D.V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
|
||||
D.C i -> new "Int" [JS.EInt i]
|
||||
D.F (CId f) -> JS.ECall (JS.EMember (JS.EVar l) (JS.Ident "rule")) [JS.EStr f, JS.EVar children]
|
||||
D.FV xs -> new "Variants" (map f xs)
|
||||
D.W str x -> new "Suffix" [JS.EStr str, f x]
|
||||
D.RP x y -> new "Rp" [f x, f y]
|
||||
D.TM -> new "Meta" []
|
||||
|
||||
tokn2js :: C.Tokn -> JS.Expr
|
||||
tokn2js (C.KS s) = mkStr s
|
||||
tokn2js (C.KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
tokn2js :: D.Tokn -> JS.Expr
|
||||
tokn2js (D.KS s) = mkStr s
|
||||
tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME
|
||||
|
||||
mkStr :: String -> JS.Expr
|
||||
mkStr s = new "Str" [JS.EStr s]
|
||||
@@ -91,7 +91,7 @@ gfcc2grammarRef :: D.GFCC -> String
|
||||
gfcc2grammarRef gfcc =
|
||||
encodeUTF8 $ refs
|
||||
where
|
||||
C.CId abstr = D.absname gfcc
|
||||
CId abstr = D.absname gfcc
|
||||
refs = unlines $ [
|
||||
"// Grammar Reference",
|
||||
"function concreteReference(concreteSyntax, concreteSyntaxName) {",
|
||||
@@ -102,5 +102,5 @@ gfcc2grammarRef gfcc =
|
||||
"var myConcrete = new Array();"
|
||||
] ++ [
|
||||
"myConcrete.push(new concreteReference(" ++ c ++ ",\"" ++ c ++ "\"));"
|
||||
| C.CId c <- D.cncnames gfcc]
|
||||
| CId c <- D.cncnames gfcc]
|
||||
|
||||
|
||||
@@ -6,8 +6,9 @@ import GF.Grammar.Grammar
|
||||
import qualified GF.Grammar.Lookup as Look
|
||||
|
||||
import qualified GF.GFCC.Macros as CM
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as C
|
||||
import qualified GF.GFCC.DataGFCC as D
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import qualified GF.Grammar.Abstract as A
|
||||
import qualified GF.Grammar.Macros as GM
|
||||
--import qualified GF.Grammar.Compute as Compute
|
||||
@@ -15,6 +16,7 @@ import qualified GF.Infra.Modules as M
|
||||
import qualified GF.Infra.Option as O
|
||||
|
||||
import GF.Devel.PrGrammar
|
||||
import GF.Devel.PrintGFCC
|
||||
import GF.Devel.ModDeps
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
@@ -29,7 +31,7 @@ import Debug.Trace ----
|
||||
-- the main function: generate GFCC from GF.
|
||||
|
||||
prGrammar2gfcc :: Options -> String -> SourceGrammar -> (String,String)
|
||||
prGrammar2gfcc opts cnc gr = (abs, D.printGFCC gc) where
|
||||
prGrammar2gfcc opts cnc gr = (abs,printGFCC gc) where
|
||||
(abs,gc) = mkCanon2gfcc opts cnc gr
|
||||
|
||||
mkCanon2gfcc :: Options -> String -> SourceGrammar -> (String,D.GFCC)
|
||||
@@ -51,9 +53,9 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
||||
an = (i2i a)
|
||||
cns = map (i2i . fst) cms
|
||||
abs = D.Abstr aflags funs cats catfuns
|
||||
gflags = Map.fromList [(C.CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
||||
gflags = Map.fromList [(CId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
||||
where fg = "firstlang"
|
||||
aflags = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.flags abm]
|
||||
aflags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags abm]
|
||||
mkDef pty = case pty of
|
||||
Yes t -> mkExp t
|
||||
_ -> CM.primNotion
|
||||
@@ -73,7 +75,7 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
||||
(lang,D.Concr flags lins opers lincats lindefs printnames params)
|
||||
where
|
||||
js = tree2list (M.jments mo)
|
||||
flags = Map.fromList [(C.CId f,x) | Opt (f,[x]) <- M.flags mo]
|
||||
flags = Map.fromList [(CId f,x) | Opt (f,[x]) <- M.flags mo]
|
||||
opers = Map.fromAscList [] -- opers will be created as optimization
|
||||
utf = if elem (Opt ("coding",["utf8"])) (M.flags mo)
|
||||
then D.convertStringsInTerm decodeUTF8 else id
|
||||
@@ -89,8 +91,8 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
||||
params = Map.fromAscList
|
||||
[(i2i c, pars lang0 c) | (c,CncCat (Yes ty) _ _) <- js]
|
||||
|
||||
i2i :: Ident -> C.CId
|
||||
i2i = C.CId . prIdent
|
||||
i2i :: Ident -> CId
|
||||
i2i = CId . prIdent
|
||||
|
||||
mkType :: A.Type -> C.Type
|
||||
mkType t = case GM.typeForm t of
|
||||
|
||||
@@ -1,6 +1,8 @@
|
||||
module GF.Devel.PrintGFCC where
|
||||
|
||||
import GF.GFCC.DataGFCC (GFCC,printGFCC)
|
||||
import GF.GFCC.DataGFCC (GFCC)
|
||||
import GF.GFCC.Raw.ConvertGFCC (fromGFCC)
|
||||
import GF.GFCC.Raw.PrintGFCCRaw (printTree)
|
||||
import GF.Devel.GFCCtoHaskell
|
||||
import GF.Devel.GFCCtoJS
|
||||
|
||||
@@ -14,3 +16,6 @@ prGFCC printer gr = case printer of
|
||||
"jsref" -> gfcc2grammarRef gr
|
||||
_ -> printGFCC gr
|
||||
|
||||
printGFCC :: GFCC -> String
|
||||
printGFCC = printTree . fromGFCC
|
||||
|
||||
|
||||
@@ -38,7 +38,7 @@ import Data.Array
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import GF.Formalism.Utilities
|
||||
import qualified GF.GFCC.AbsGFCC as AbsGFCC
|
||||
import qualified GF.GFCC.Raw.AbsGFCCRaw as AbsGFCC
|
||||
import GF.Infra.PrintClass
|
||||
|
||||
|
||||
|
||||
@@ -19,8 +19,9 @@ import GF.GFCC.Linearize
|
||||
import GF.GFCC.Generate
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.ParGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Raw.ConvertGFCC
|
||||
import GF.GFCC.Raw.ParGFCCRaw
|
||||
import GF.Command.PPrTree
|
||||
|
||||
import GF.GFCC.ErrM
|
||||
@@ -81,8 +82,10 @@ file2grammar f = do
|
||||
gfcc2parsers gfcc =
|
||||
[(lang, buildFCFPInfo fcfg) | (CId lang,fcfg) <- convertGrammar gfcc]
|
||||
|
||||
file2gfcc f =
|
||||
readFileIf f >>= err (error) (return . mkGFCC) . pGrammar . myLexer
|
||||
file2gfcc f = do
|
||||
s <- readFileIf f
|
||||
g <- parseGrammar s
|
||||
return $ toGFCC g
|
||||
|
||||
linearize mgr lang = GF.GFCC.Linearize.linearize (gfcc mgr) (CId lang)
|
||||
|
||||
|
||||
@@ -1,82 +0,0 @@
|
||||
module GF.GFCC.AbsGFCC where
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
newtype CId = CId String deriving (Eq,Ord,Show)
|
||||
data Grammar =
|
||||
Grm CId [CId] [Flag] Abstract [Concrete]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Abstract =
|
||||
Abs [Flag] [FunDef] [CatDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Concrete =
|
||||
Cnc CId [Flag] [LinDef] [LinDef] [LinDef] [LinDef] [LinDef] [LinDef]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Flag =
|
||||
Flg CId String
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data CatDef =
|
||||
Cat CId [Hypo]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data FunDef =
|
||||
Fun CId Type Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinDef =
|
||||
Lin CId Term
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Type =
|
||||
DTyp [Hypo] CId [Exp]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Exp =
|
||||
DTr [CId] Atom [Exp]
|
||||
| EEq [Equation]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Atom =
|
||||
AC CId
|
||||
| AS String
|
||||
| AI Integer
|
||||
| AF Double
|
||||
| AM Integer
|
||||
| AV CId
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Term =
|
||||
R [Term]
|
||||
| P Term Term
|
||||
| S [Term]
|
||||
| K Tokn
|
||||
| V Int --H
|
||||
| C Int --H
|
||||
| F CId
|
||||
| FV [Term]
|
||||
| W String Term
|
||||
| TM
|
||||
| RP Term Term
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Tokn =
|
||||
KS String
|
||||
| KP [String] [Variant]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Variant =
|
||||
Var [String] [String]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Hypo =
|
||||
Hyp CId Type
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data Equation =
|
||||
Equ [Exp] Exp
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
module GF.GFCC.CheckGFCC (checkGFCC, checkGFCCio) where
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.ErrM
|
||||
|
||||
import qualified Data.Map as Map
|
||||
@@ -39,7 +39,7 @@ labelBoolErr ms iob = do
|
||||
|
||||
checkConcrete :: GFCC -> (CId,Concr) -> Err ((CId,Concr),Bool)
|
||||
checkConcrete gfcc (lang,cnc) =
|
||||
labelBoolErr ("happened in language " ++ prt lang) $ do
|
||||
labelBoolErr ("happened in language " ++ printCId lang) $ do
|
||||
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
|
||||
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
|
||||
where
|
||||
@@ -47,7 +47,7 @@ checkConcrete gfcc (lang,cnc) =
|
||||
|
||||
checkLin :: GFCC -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
|
||||
checkLin gfcc lang (f,t) =
|
||||
labelBoolErr ("happened in function " ++ prt f) $ do
|
||||
labelBoolErr ("happened in function " ++ printCId f) $ do
|
||||
(t',b) <- checkTerm (lintype gfcc lang f) t --- $ inline gfcc lang t
|
||||
return ((f,t'),b)
|
||||
|
||||
@@ -62,7 +62,7 @@ inferTerm args trm = case trm of
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
let tys' = filter (/=str) tys
|
||||
testErr (null tys')
|
||||
("expected Str in " ++ prt trm ++ " not " ++ unwords (map prt tys'))
|
||||
("expected Str in " ++ show trm ++ " not " ++ unwords (map show tys'))
|
||||
return (S ts',str)
|
||||
R ts -> do
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
@@ -78,21 +78,21 @@ inferTerm args trm = case trm of
|
||||
|
||||
C i -> do
|
||||
testErr (i < length tys)
|
||||
("required more than " ++ show i ++ " fields in " ++ prt (R tys))
|
||||
("required more than " ++ show i ++ " fields in " ++ show (R tys))
|
||||
return (P t' u', tys !! i) -- record: index must be known
|
||||
_ -> do
|
||||
let typ = head tys
|
||||
testErr (all (==typ) tys) ("different types in table " ++ prt trm)
|
||||
testErr (all (==typ) tys) ("different types in table " ++ show trm)
|
||||
return (P t' u', typ) -- table: types must be same
|
||||
_ -> Bad $ "projection from " ++ prt t ++ " : " ++ prt tt
|
||||
_ -> Bad $ "projection from " ++ show t ++ " : " ++ show tt
|
||||
FV [] -> returnt TM ----
|
||||
FV (t:ts) -> do
|
||||
(t',ty) <- infer t
|
||||
(ts',tys) <- mapM infer ts >>= return . unzip
|
||||
testErr (all (eqType ty) tys) ("different types in variants " ++ prt trm)
|
||||
testErr (all (eqType ty) tys) ("different types in variants " ++ show trm)
|
||||
return (FV (t':ts'),ty)
|
||||
W s r -> infer r
|
||||
_ -> Bad ("no type inference for " ++ prt trm)
|
||||
_ -> Bad ("no type inference for " ++ show trm)
|
||||
where
|
||||
returnt ty = return (trm,ty)
|
||||
infer = inferTerm args
|
||||
@@ -102,9 +102,9 @@ checkTerm (args,val) trm = case inferTerm args trm of
|
||||
Ok (t,ty) -> if eqType ty val
|
||||
then return (t,True)
|
||||
else do
|
||||
msg ("term: " ++ prt trm ++
|
||||
"\nexpected type: " ++ prt val ++
|
||||
"\ninferred type: " ++ prt ty)
|
||||
msg ("term: " ++ show trm ++
|
||||
"\nexpected type: " ++ show val ++
|
||||
"\ninferred type: " ++ show ty)
|
||||
return (t,False)
|
||||
Bad s -> do
|
||||
msg s
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module GF.GFCC.DataGFCC where
|
||||
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.PrintGFCC
|
||||
import GF.Infra.CompactPrint
|
||||
import GF.Text.UTF8
|
||||
|
||||
|
||||
@@ -2,7 +2,7 @@ module GF.GFCC.Generate where
|
||||
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
|
||||
import qualified Data.Map as M
|
||||
import System.Random
|
||||
|
||||
@@ -2,7 +2,7 @@ module GF.GFCC.Linearize where
|
||||
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import Data.Map
|
||||
import Data.List
|
||||
|
||||
@@ -56,7 +56,7 @@ compute mcfg lang args = comp where
|
||||
|
||||
idx xs i = if i > length xs - 1
|
||||
then trace
|
||||
("too large " ++ show i ++ " for\n" ++ unlines (lmap prt xs) ++ "\n") TM
|
||||
("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") TM
|
||||
else xs !! i
|
||||
|
||||
proj r p = case (r,p) of
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
module GF.GFCC.Macros where
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.PrintGFCC
|
||||
----import GF.GFCC.PrintGFCC
|
||||
import Data.Map
|
||||
import Data.List
|
||||
|
||||
@@ -83,9 +83,6 @@ term0 _ = TM
|
||||
kks :: String -> Term
|
||||
kks = K . KS
|
||||
|
||||
prt :: Print a => a -> String
|
||||
prt = printTree
|
||||
|
||||
-- lookup with default value
|
||||
lookMap :: (Show i, Ord i) => a -> i -> Map i a -> a
|
||||
lookMap d c m = maybe d id $ Data.Map.lookup c m
|
||||
|
||||
@@ -1,6 +1,6 @@
|
||||
module GF.GFCC.OptimizeGFCC where
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.DataGFCC
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,217 +0,0 @@
|
||||
{-# OPTIONS -fno-warn-incomplete-patterns #-}
|
||||
module GF.GFCC.PrintGFCC where
|
||||
|
||||
-- pretty-printer generated by the BNF converter
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import Char
|
||||
|
||||
-- the top-level printing method
|
||||
printTree :: Print a => a -> String
|
||||
printTree = render . prt 0
|
||||
|
||||
type Doc = [ShowS] -> [ShowS]
|
||||
|
||||
doc :: ShowS -> Doc
|
||||
doc = (:)
|
||||
|
||||
render :: Doc -> String
|
||||
render d = rend 0 (map ($ "") $ d []) "" where
|
||||
rend i ss = case ss of
|
||||
"[" :ts -> showChar '[' . rend i ts
|
||||
"(" :ts -> showChar '(' . rend i ts
|
||||
"{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
|
||||
"}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
|
||||
"}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
|
||||
";" :ts -> showChar ';' . new i . rend i ts
|
||||
t : "," :ts -> showString t . space "," . rend i ts
|
||||
t : ")" :ts -> showString t . showChar ')' . rend i ts
|
||||
t : "]" :ts -> showString t . showChar ']' . rend i ts
|
||||
t :ts -> space t . rend i ts
|
||||
_ -> id
|
||||
new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
|
||||
space t = showString t . (\s -> if null s then "" else (' ':s))
|
||||
|
||||
parenth :: Doc -> Doc
|
||||
parenth ss = doc (showChar '(') . ss . doc (showChar ')')
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
concatD :: [Doc] -> Doc
|
||||
concatD = foldr (.) id
|
||||
|
||||
replicateS :: Int -> ShowS -> ShowS
|
||||
replicateS n f = concatS (replicate n f)
|
||||
|
||||
-- the printer class does the job
|
||||
class Print a where
|
||||
prt :: Int -> a -> Doc
|
||||
prtList :: [a] -> Doc
|
||||
prtList = concatD . map (prt 0)
|
||||
|
||||
instance Print a => Print [a] where
|
||||
prt _ = prtList
|
||||
|
||||
instance Print Char where
|
||||
prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
|
||||
prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
|
||||
|
||||
mkEsc :: Char -> Char -> ShowS
|
||||
mkEsc q s = case s of
|
||||
_ | s == q -> showChar '\\' . showChar s
|
||||
'\\'-> showString "\\\\"
|
||||
'\n' -> showString "\\n"
|
||||
'\t' -> showString "\\t"
|
||||
_ -> showChar s
|
||||
|
||||
prPrec :: Int -> Int -> Doc -> Doc
|
||||
prPrec i j = if j<i then parenth else id
|
||||
|
||||
|
||||
instance Print Integer where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
instance Print Int where --H
|
||||
prt _ x = doc (shows x) --H
|
||||
|
||||
instance Print Double where
|
||||
prt _ x = doc (shows x)
|
||||
|
||||
|
||||
|
||||
instance Print CId where
|
||||
prt _ (CId i) = doc (showString i)
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
|
||||
|
||||
instance Print Grammar where
|
||||
prt i e = case e of
|
||||
Grm cid cids flags abstract concretes -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 cid , doc (showString "(") , prt 0 cids , doc (showString ")") , doc (showString "(") , prt 0 flags , doc (showString ")") , doc (showString ";") , prt 0 abstract , doc (showString ";") , prt 0 concretes])
|
||||
|
||||
|
||||
instance Print Abstract where
|
||||
prt i e = case e of
|
||||
Abs flags fundefs catdefs -> prPrec i 0 (concatD [doc (showString "abstract") , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "fun") , prt 0 fundefs , doc (showString "cat") , prt 0 catdefs , doc (showString "}")])
|
||||
|
||||
|
||||
instance Print Concrete where
|
||||
prt i e = case e of
|
||||
Cnc cid flags lindefs0 lindefs1 lindefs2 lindefs3 lindefs4 lindefs -> prPrec i 0 (concatD [doc (showString "concrete") , prt 0 cid , doc (showString "{") , doc (showString "flags") , prt 0 flags , doc (showString "lin") , prt 0 lindefs0 , doc (showString "oper") , prt 0 lindefs1 , doc (showString "lincat") , prt 0 lindefs2 , doc (showString "lindef") , prt 0 lindefs3 , doc (showString "printname") , prt 0 lindefs4 , doc (showString "param") , prt 0 lindefs , doc (showString "}")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Flag where
|
||||
prt i e = case e of
|
||||
Flg cid str -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 str])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print CatDef where
|
||||
prt i e = case e of
|
||||
Cat cid hypos -> prPrec i 0 (concatD [prt 0 cid , doc (showString "[") , prt 0 hypos , doc (showString "]")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print FunDef where
|
||||
prt i e = case e of
|
||||
Fun cid type' exp -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type' , doc (showString "=") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print LinDef where
|
||||
prt i e = case e of
|
||||
Lin cid term -> prPrec i 0 (concatD [prt 0 cid , doc (showString "=") , prt 0 term])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
instance Print Type where
|
||||
prt i e = case e of
|
||||
DTyp hypos cid exps -> prPrec i 0 (concatD [doc (showString "[") , prt 0 hypos , doc (showString "]") , prt 0 cid , prt 0 exps])
|
||||
|
||||
|
||||
instance Print Exp where
|
||||
prt i e = case e of
|
||||
DTr cids atom exps -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "(") , prt 0 cids , doc (showString ")") , prt 0 atom , prt 0 exps , doc (showString "]")])
|
||||
EEq equations -> prPrec i 0 (concatD [doc (showString "{") , prt 0 equations , doc (showString "}")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , prt 0 xs])
|
||||
|
||||
instance Print Atom where
|
||||
prt i e = case e of
|
||||
AC cid -> prPrec i 0 (concatD [prt 0 cid])
|
||||
AS str -> prPrec i 0 (concatD [prt 0 str])
|
||||
AI n -> prPrec i 0 (concatD [prt 0 n])
|
||||
AF d -> prPrec i 0 (concatD [prt 0 d])
|
||||
AM n -> prPrec i 0 (concatD [doc (showString "?") , prt 0 n])
|
||||
AV cid -> prPrec i 0 (concatD [doc (showString "$") , prt 0 cid])
|
||||
|
||||
|
||||
instance Print Term where
|
||||
prt i e = case e of
|
||||
R terms -> prPrec i 0 (concatD [doc (showString "[") , prt 0 terms , doc (showString "]")])
|
||||
P term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "!") , prt 0 term , doc (showString ")")])
|
||||
S terms -> prPrec i 0 (concatD [doc (showString "(") , prt 0 terms , doc (showString ")")])
|
||||
K tokn -> prPrec i 0 (concatD [prt 0 tokn])
|
||||
V n -> prPrec i 0 (concatD [doc (showString "$") , prt 0 n])
|
||||
C n -> prPrec i 0 (concatD [prt 0 n])
|
||||
F cid -> prPrec i 0 (concatD [prt 0 cid])
|
||||
FV terms -> prPrec i 0 (concatD [doc (showString "[|") , prt 0 terms , doc (showString "|]")])
|
||||
W str term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 str , doc (showString "+") , prt 0 term , doc (showString ")")])
|
||||
TM -> prPrec i 0 (concatD [doc (showString "?")])
|
||||
RP term0 term -> prPrec i 0 (concatD [doc (showString "(") , prt 0 term0 , doc (showString "@") , prt 0 term , doc (showString ")")])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Tokn where
|
||||
prt i e = case e of
|
||||
KS str -> prPrec i 0 (concatD [prt 0 str])
|
||||
KP strs variants -> prPrec i 0 (concatD [doc (showString "[") , doc (showString "pre") , prt 0 strs , doc (showString "[") , prt 0 variants , doc (showString "]") , doc (showString "]")])
|
||||
|
||||
|
||||
instance Print Variant where
|
||||
prt i e = case e of
|
||||
Var strs0 strs -> prPrec i 0 (concatD [prt 0 strs0 , doc (showString "/") , prt 0 strs])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Hypo where
|
||||
prt i e = case e of
|
||||
Hyp cid type' -> prPrec i 0 (concatD [prt 0 cid , doc (showString ":") , prt 0 type'])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
[x] -> (concatD [prt 0 x])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
|
||||
|
||||
instance Print Equation where
|
||||
prt i e = case e of
|
||||
Equ exps exp -> prPrec i 0 (concatD [prt 0 exps , doc (showString "->") , prt 0 exp])
|
||||
|
||||
prtList es = case es of
|
||||
[] -> (concatD [])
|
||||
x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
|
||||
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
module GF.GFCC.Raw.ConvertGFCC where
|
||||
module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
|
||||
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw
|
||||
@@ -7,9 +7,9 @@ import Data.Map
|
||||
|
||||
-- convert parsed grammar to internal GFCC
|
||||
|
||||
mkGFCC :: Grammar -> GFCC
|
||||
mkGFCC (Grm [
|
||||
App (CId "abstract") [AId a],
|
||||
toGFCC :: Grammar -> GFCC
|
||||
toGFCC (Grm [
|
||||
AId a,
|
||||
App (CId "concrete") cs,
|
||||
App (CId "flags") gfs,
|
||||
ab@(
|
||||
@@ -37,8 +37,7 @@ mkGFCC (Grm [
|
||||
}
|
||||
where
|
||||
mkCnc (
|
||||
App (CId "concrete") [
|
||||
AId lang,
|
||||
App lang [
|
||||
App (CId "flags") fls,
|
||||
App (CId "lin") ls,
|
||||
App (CId "oper") ops,
|
||||
@@ -72,7 +71,9 @@ toHypo e = case e of
|
||||
toExp :: RExp -> Exp
|
||||
toExp e = case e of
|
||||
App fun [App (CId "abs") xs, App (CId "arg") exps] ->
|
||||
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
|
||||
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
|
||||
App (CId "Eq") _ -> EEq [] ----
|
||||
AMet -> DTr [] (AM 0) []
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
toTerm :: RExp -> Term
|
||||
@@ -90,29 +91,69 @@ toTerm e = case e of
|
||||
AStr s -> K (KS s) ----
|
||||
_ -> error $ "term " ++ show e
|
||||
|
||||
------------------------------
|
||||
--- from internal to parser --
|
||||
------------------------------
|
||||
|
||||
{-
|
||||
-- convert internal GFCC and pretty-print it
|
||||
|
||||
printGFCC :: GFCC -> String
|
||||
printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
|
||||
(absname gfcc)
|
||||
(cncnames gfcc)
|
||||
[Flg f v | (f,v) <- assocs (gflags gfcc)]
|
||||
(Abs
|
||||
[Flg f v | (f,v) <- assocs (aflags (abstract gfcc))]
|
||||
[Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
|
||||
[Cat f v | (f,v) <- assocs (cats (abstract gfcc))]
|
||||
)
|
||||
[fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
|
||||
fromGFCC :: GFCC -> Grammar
|
||||
fromGFCC gfcc0 = Grm [
|
||||
AId (absname gfcc),
|
||||
app "concrete" (lmap AId (cncnames gfcc)),
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (gflags gfcc)],
|
||||
app "abstract" [
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (aflags agfcc)],
|
||||
app "fun" [App f [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)],
|
||||
app "cat" [App f (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)]
|
||||
],
|
||||
app "concrete" [App lang (fromConcrete c) | (lang,c) <- toList (concretes gfcc)]
|
||||
]
|
||||
where
|
||||
fromCnc lang cnc = Cnc lang
|
||||
[Flg f v | (f,v) <- assocs (cflags cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lins cnc)]
|
||||
[Lin f v | (f,v) <- assocs (opers cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lincats cnc)]
|
||||
[Lin f v | (f,v) <- assocs (lindefs cnc)]
|
||||
[Lin f v | (f,v) <- assocs (printnames cnc)]
|
||||
[Lin f v | (f,v) <- assocs (paramlincats cnc)]
|
||||
gfcc = utf8GFCC gfcc0
|
||||
-}
|
||||
gfcc = utf8GFCC gfcc0
|
||||
app s = App (CId s)
|
||||
agfcc = abstract gfcc
|
||||
fromConcrete cnc = [
|
||||
app "flags" [App f [AStr v] | (f,v) <- toList (cflags cnc)],
|
||||
app "lin" [App f [fromTerm v] | (f,v) <- toList (lins cnc)],
|
||||
app "oper" [App f [fromTerm v] | (f,v) <- toList (opers cnc)],
|
||||
app "lincat" [App f [fromTerm v] | (f,v) <- toList (lincats cnc)],
|
||||
app "lindef" [App f [fromTerm v] | (f,v) <- toList (lindefs cnc)],
|
||||
app "printname" [App f [fromTerm v] | (f,v) <- toList (printnames cnc)],
|
||||
app "param" [App f [fromTerm v] | (f,v) <- toList (paramlincats cnc)]
|
||||
]
|
||||
|
||||
fromType :: Type -> RExp
|
||||
fromType e = case e of
|
||||
DTyp hypos cat exps ->
|
||||
App cat [
|
||||
App (CId "hypo") (lmap fromHypo hypos),
|
||||
App (CId "arg") (lmap fromExp exps)]
|
||||
|
||||
fromHypo :: Hypo -> RExp
|
||||
fromHypo e = case e of
|
||||
Hyp x typ -> App x [fromType typ]
|
||||
|
||||
fromExp :: Exp -> RExp
|
||||
fromExp e = case e of
|
||||
DTr xs (AC fun) exps ->
|
||||
App fun [App (CId "abs") (lmap AId xs), App (CId "arg") (lmap fromExp exps)]
|
||||
DTr xs (AM _) exps -> AMet ----
|
||||
EEq _ -> App (CId "Eq") [] ----
|
||||
_ -> error $ "exp " ++ show e
|
||||
|
||||
fromTerm :: Term -> RExp
|
||||
fromTerm e = case e of
|
||||
R es -> app "R" (lmap fromTerm es)
|
||||
S es -> app "S" (lmap fromTerm es)
|
||||
FV es -> app "FV" (lmap fromTerm es)
|
||||
P e v -> app "P" [fromTerm e, fromTerm v]
|
||||
RP e v -> app "RP" [fromTerm e, fromTerm v] ----
|
||||
W s v -> app "W" [AStr s, fromTerm v]
|
||||
C i -> AInt (toInteger i)
|
||||
TM -> AMet
|
||||
F f -> AId f
|
||||
V i -> App (CId "A") [AInt (toInteger i)]
|
||||
K (KS s) -> AStr s ----
|
||||
K (KP d vs) -> app "FV" (str d : [str v | Var v _ <- vs]) ----
|
||||
where
|
||||
app = App . CId
|
||||
str v = app "S" (lmap AStr v)
|
||||
|
||||
@@ -8,8 +8,8 @@ module GF.GFCC.ShowLinearize (
|
||||
import GF.GFCC.Linearize
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.PrintGFCC ----
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
--import GF.GFCC.PrintGFCC ----
|
||||
|
||||
import GF.Data.Operations
|
||||
import Data.List
|
||||
@@ -46,7 +46,7 @@ mkRecord typ trm = case (typ,trm) of
|
||||
(_,W s (R ts)) -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
|
||||
(FV ps, C i) -> RCon $ str $ ps !! i
|
||||
(S [], _) -> RS $ realize trm
|
||||
_ -> RS $ printTree trm
|
||||
_ -> RS $ show trm ---- printTree trm
|
||||
where
|
||||
str = realize
|
||||
|
||||
@@ -82,6 +82,6 @@ recLinearize gfcc lang exp = mkRecord typ $ linExp gfcc lang exp where
|
||||
|
||||
-- show GFCC term
|
||||
termLinearize :: GFCC -> CId -> Exp -> String
|
||||
termLinearize gfcc lang = printTree . linExp gfcc lang
|
||||
termLinearize gfcc lang = show . linExp gfcc lang
|
||||
|
||||
|
||||
|
||||
@@ -21,7 +21,8 @@ import GF.Formalism.Utilities
|
||||
import qualified GF.Parsing.FCFG.Active as Active
|
||||
import GF.Parsing.FCFG.PInfo
|
||||
|
||||
import GF.GFCC.AbsGFCC
|
||||
import GF.GFCC.DataGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import GF.GFCC.Macros
|
||||
import GF.GFCC.ErrM
|
||||
|
||||
|
||||
@@ -15,7 +15,7 @@ import GF.Formalism.FCFG
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Parsing.FCFG.Range
|
||||
import qualified GF.GFCC.AbsGFCC as AbsGFCC
|
||||
import qualified GF.GFCC.Raw.AbsGFCCRaw as AbsGFCC
|
||||
|
||||
import Data.Array
|
||||
import Data.Maybe
|
||||
|
||||
@@ -24,7 +24,8 @@ import GF.Data.Operations (Err(..))
|
||||
import qualified GF.Grammar.Grammar as Grammar
|
||||
import qualified GF.Grammar.Macros as Macros
|
||||
import qualified GF.Canon.AbsGFC as AbsGFC
|
||||
import qualified GF.GFCC.AbsGFCC as AbsGFCC
|
||||
import qualified GF.GFCC.DataGFCC as AbsGFCC
|
||||
import GF.GFCC.Raw.AbsGFCCRaw (CId (..))
|
||||
import qualified GF.GFCC.ErrM as ErrM
|
||||
import qualified GF.Infra.Ident as Ident
|
||||
import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok)
|
||||
@@ -134,7 +135,7 @@ parse "m" strategy pinfo abs startCat inString
|
||||
-- parsing via FCFG
|
||||
parse "f" strategy pinfo abs startCat inString =
|
||||
let Ident.IC x = cfCat2Ident startCat
|
||||
cat' = AbsGFCC.CId x
|
||||
cat' = CId x
|
||||
in case PF.parseFCF strategy (fcfPInfo pinfo) cat' (map prCFTok inString) of
|
||||
ErrM.Ok es -> Ok (map (exp2term abs) es)
|
||||
ErrM.Bad msg -> Bad msg
|
||||
@@ -144,7 +145,7 @@ parse "f" strategy pinfo abs startCat inString =
|
||||
selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy
|
||||
|
||||
cnv_forests FMeta = FMeta
|
||||
cnv_forests (FNode (Name (AbsGFCC.CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss)
|
||||
cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss)
|
||||
cnv_forests (FString x) = FString x
|
||||
cnv_forests (FInt x) = FInt x
|
||||
cnv_forests (FFloat x) = FFloat x
|
||||
@@ -153,7 +154,7 @@ cnv_profile (Unify x) = Unify x
|
||||
cnv_profile (Constant x) = Constant (cnv_forests2 x)
|
||||
|
||||
cnv_forests2 FMeta = FMeta
|
||||
cnv_forests2 (FNode (AbsGFCC.CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss)
|
||||
cnv_forests2 (FNode (CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss)
|
||||
cnv_forests2 (FString x) = FString x
|
||||
cnv_forests2 (FInt x) = FInt x
|
||||
cnv_forests2 (FFloat x) = FFloat x
|
||||
@@ -173,7 +174,7 @@ exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings
|
||||
Macros.mkApp (atom2term abs a) (map (exp2term abs) es)
|
||||
|
||||
atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term
|
||||
atom2term abs (AbsGFCC.AC (AbsGFCC.CId f)) = Macros.qq (abs,Ident.IC f)
|
||||
atom2term abs (AbsGFCC.AC (CId f)) = Macros.qq (abs,Ident.IC f)
|
||||
atom2term abs (AbsGFCC.AS s) = Macros.string2term s
|
||||
atom2term abs (AbsGFCC.AI n) = Macros.int2term n
|
||||
atom2term abs (AbsGFCC.AF f) = Macros.float2term f
|
||||
|
||||
@@ -11,8 +11,8 @@
|
||||
module GF.Speech.GrammarToVoiceXML (grammar2vxml) where
|
||||
|
||||
import GF.Canon.CanonToGFCC (mkCanon2gfcc)
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import GF.GFCC.DataGFCC (GFCC(..), Abstr(..), mkGFCC)
|
||||
import qualified GF.GFCC.Raw.AbsGFCCRaw as C
|
||||
import GF.GFCC.DataGFCC (GFCC(..), Abstr(..))
|
||||
import GF.GFCC.Macros
|
||||
import qualified GF.Canon.GFC as GFC
|
||||
import GF.Canon.AbsGFC (Term)
|
||||
@@ -281,4 +281,4 @@ isConsFun f = "Cons" `isPrefixOf` prIdent f
|
||||
baseSize :: (VIdent, [(VIdent, [VIdent])]) -> Int
|
||||
baseSize (_,rules) = length bs
|
||||
where Just (_,bs) = find (isBaseFun . fst) rules
|
||||
-}
|
||||
-}
|
||||
|
||||
@@ -17,7 +17,7 @@
|
||||
module GF.Speech.TransformCFG where
|
||||
|
||||
import GF.Canon.CanonToGFCC (mkCanon2gfcc)
|
||||
import qualified GF.GFCC.AbsGFCC as C
|
||||
import qualified GF.GFCC.Raw.AbsGFCCRaw as C
|
||||
import GF.GFCC.Macros (lookType,catSkeleton)
|
||||
import GF.GFCC.DataGFCC (GFCC)
|
||||
import GF.Conversion.Types
|
||||
|
||||
Reference in New Issue
Block a user