From 954740933af1f60099bdc5c180bcc1f240eb614c Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Thu, 22 May 2008 15:47:15 +0000 Subject: move GFCCtoHaskell and GFCCtoJS to GF.GFCC.* --- src-3.0/GF/Devel/GFCCtoHaskell.hs | 212 -------------------------------------- src-3.0/GF/Devel/GFCCtoJS.hs | 132 ------------------------ src-3.0/GF/GFCC/GFCCtoHaskell.hs | 212 ++++++++++++++++++++++++++++++++++++++ src-3.0/GF/GFCC/GFCCtoJS.hs | 132 ++++++++++++++++++++++++ src-3.0/GF/GFCC/PrintGFCC.hs | 4 +- 5 files changed, 346 insertions(+), 346 deletions(-) delete mode 100644 src-3.0/GF/Devel/GFCCtoHaskell.hs delete mode 100644 src-3.0/GF/Devel/GFCCtoJS.hs create mode 100644 src-3.0/GF/GFCC/GFCCtoHaskell.hs create mode 100644 src-3.0/GF/GFCC/GFCCtoJS.hs diff --git a/src-3.0/GF/Devel/GFCCtoHaskell.hs b/src-3.0/GF/Devel/GFCCtoHaskell.hs deleted file mode 100644 index 4b042d9ec..000000000 --- a/src-3.0/GF/Devel/GFCCtoHaskell.hs +++ /dev/null @@ -1,212 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : GFCCtoHaskell --- Maintainer : Aarne Ranta --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/17 12:39:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- to write a GF abstract grammar into a Haskell module with translations from --- data objects into GF trees. Example: GSyntax for Agda. --- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ------------------------------------------------------------------------------ - -module GF.Devel.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where - -import GF.GFCC.Macros -import GF.GFCC.DataGFCC -import GF.GFCC.CId - -import GF.Data.Operations -import GF.Text.UTF8 - -import Data.List --(isPrefixOf, find, intersperse) -import qualified Data.Map as Map - --- | the main function -grammar2haskell :: GFCC -> String -grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $ - haskPreamble ++ [datatypes gr', gfinstances gr'] - where gr' = hSkeleton gr - -grammar2haskellGADT :: GFCC -> String -grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $ - ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ - haskPreamble ++ [datatypesGADT gr', gfinstances gr'] - where gr' = hSkeleton gr - --- | by this you can prefix all identifiers with stg; the default is 'G' -gId :: OIdent -> OIdent -gId i = 'G':i - -haskPreamble = - [ - "module GSyntax where", - "", - "import GF.GFCC.DataGFCC", - "import GF.GFCC.CId", - "----------------------------------------------------", - "-- automatic translation from GF to Haskell", - "----------------------------------------------------", - "", - "class Gf a where", - " gf :: a -> Exp", - " fg :: Exp -> a", - "", - predefInst "GString" "String" "DTr [] (AS s) []", - "", - predefInst "GInt" "Integer" "DTr [] (AI s) []", - "", - predefInst "GFloat" "Double" "DTr [] (AF s) []", - "", - "----------------------------------------------------", - "-- below this line machine-generated", - "----------------------------------------------------", - "" - ] - -predefInst gtyp typ patt = - "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ - "instance Gf" +++ gtyp +++ "where" ++++ - " gf (" ++ gtyp +++ "s) =" +++ patt ++++ - " fg t =" ++++ - " case t of" ++++ - " " +++ patt +++ " ->" +++ gtyp +++ "s" ++++ - " _ -> error (\"no" +++ gtyp +++ "\" ++ show t)" - -type OIdent = String - -type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] - -datatypes, gfinstances :: (String,HSkeleton) -> String -datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd -gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g - -hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String - -hDatatype ("Cn",_) = "" --- -hDatatype (cat,[]) = "" -hDatatype (cat,rules) | isListCat (cat,rules) = - "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" - +++ "deriving Show" -hDatatype (cat,rules) = - "data" +++ gId cat +++ "=" ++ - (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) - [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ - " deriving Show" - --- GADT version of data types -datatypesGADT :: (String,HSkeleton) -> String -datatypesGADT (_,skel) = - unlines (concatMap hCatTypeGADT skel) - +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) - -hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hCatTypeGADT (cat,rules) - = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", - "data"+++gId cat++"_"] - -hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT (cat, rules) - | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] - | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] - where t = "Tree" +++ gId cat ++ "_" - -gfInstance m crs = hInstance m crs ++++ fInstance m crs - -----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance m (cat,[]) = "" -hInstance m (cat,rules) - | isListCat (cat,rules) = - "instance Gf" +++ gId cat +++ "where" ++++ - " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" - +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ - " gf (" ++ gId cat +++ "(x:xs)) = " - ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] --- no show for GADTs --- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" - | otherwise = - "instance Gf" +++ gId cat +++ "where\n" ++ - unlines [mkInst f xx | (f,xx) <- rules] - where - ec = elemCat cat - baseVars = mkVars (baseSize (cat,rules)) - mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ - (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ - "=" +++ mkRHS f xx' - mkVars n = ["x" ++ show i | i <- [1..n]] - mkRHS f vars = "DTr [] (AC (CId \"" ++ f ++ "\"))" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" - - -----fInstance m ("Cn",_) = "" --- -fInstance m (cat,[]) = "" -fInstance m (cat,rules) = - " fg t =" ++++ - " case t of" ++++ - unlines [mkInst f xx | (f,xx) <- rules] ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ show t)" - where - mkInst f xx = - " DTr [] (AC (CId \"" ++ f ++ "\")) " ++ - "[" ++ prTList "," xx' ++ "]" +++ - "->" +++ mkRHS f xx' - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] - mkRHS f vars - | isListCat (cat,rules) = - if "Base" `isPrefixOf` f then - gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" - else - let (i,t) = (init vars,last vars) - in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ - gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) - | otherwise = - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- vars] - - ---type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -hSkeleton :: GFCC -> (String,HSkeleton) -hSkeleton gr = - (prCId (absname gr), - [(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) | - fs@((_, (_,c)):_) <- fns] - ) - where - fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) - valtyps (_, (_,x)) (_, (_,y)) = compare x y - valtypg (_, (_,x)) (_, (_,y)) = x == y - jty (f,(ty,_)) = (f,catSkeleton ty) - -updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton -updateSkeleton cat skel rule = - case skel of - (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr - (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule - -isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool -isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 - && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs - where c = elemCat cat - fs = map fst rules - --- | Gets the element category of a list category. -elemCat :: OIdent -> OIdent -elemCat = drop 4 - -isBaseFun :: OIdent -> Bool -isBaseFun f = "Base" `isPrefixOf` f - -isConsFun :: OIdent -> Bool -isConsFun f = "Cons" `isPrefixOf` f - -baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int -baseSize (_,rules) = length bs - where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src-3.0/GF/Devel/GFCCtoJS.hs b/src-3.0/GF/Devel/GFCCtoJS.hs deleted file mode 100644 index 80a4115d2..000000000 --- a/src-3.0/GF/Devel/GFCCtoJS.hs +++ /dev/null @@ -1,132 +0,0 @@ -module GF.Devel.GFCCtoJS (gfcc2js) where - -import qualified GF.GFCC.Macros as M -import qualified GF.GFCC.DataGFCC as D -import GF.GFCC.CId -import qualified GF.JavaScript.AbsJS as JS -import qualified GF.JavaScript.PrintJS as JS - -import GF.Formalism.FCFG -import GF.Parsing.FCFG.PInfo -import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) - -import GF.Text.UTF8 -import GF.Data.ErrM -import GF.Infra.Option - -import Control.Monad (mplus) -import Data.Array (Array) -import qualified Data.Array as Array -import Data.Maybe (fromMaybe) -import qualified Data.Map as Map - -gfcc2js :: D.GFCC -> String -gfcc2js gfcc = - encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] - where - n = prCId $ D.absname gfcc - as = D.abstract gfcc - cs = Map.assocs (D.concretes gfcc) - start = M.lookStartCat gfcc - grammar = new "GFGrammar" [abstract, concrete] - abstract = abstract2js start as - concrete = JS.EObj $ map (concrete2js start n) cs - -abstract2js :: String -> D.Abstr -> JS.Expr -abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))] - -absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property -absdef2js (f,(typ,_)) = - let (args,cat) = M.catSkeleton typ in - JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)]) - -concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property -concrete2js start n (c, cnc) = - JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++ - maybe [] (parser2js start) (D.parser cnc))) - where - l = JS.IdentPropName (JS.Ident (prCId c)) - ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] - 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)]])] - - -cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property -cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) - -term2js :: String -> String -> D.Term -> JS.Expr -term2js n l t = f t - where - f t = - case t of - 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 f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId 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 :: 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] - -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 = JS.Ident "cs" - --- Parser -parser2js :: String -> FCFPInfo -> [JS.Expr] -parser2js start p = [new "Parser" [JS.EStr start, - JS.EArray $ map frule2js (Array.elems (allRules p)), - JS.EObj $ map cats (Map.assocs (startupCats p))]] - where - cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is)) - -frule2js :: FRule -> JS.Expr -frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins] - -name2js :: FName -> JS.Expr -name2js n = case n of - Name f [p] | f == wildCId -> fromProfile p - Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] - where - fromProfile :: Profile (SyntaxForest CId) -> JS.Expr - fromProfile (Unify []) = new "MetaVar" [] - fromProfile (Unify [x]) = daughter x - fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] - fromProfile (Constant forest) = fromSyntaxForest forest - - daughter i = new "Arg" [JS.EInt i] - - fromSyntaxForest :: SyntaxForest CId -> JS.Expr - fromSyntaxForest FMeta = new "MetaVar" [] - -- FIXME: is there always just one element here? - fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)] - fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s] - fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i] - fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f] - -lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr -lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] - -sym2js :: FSymbol -> JS.Expr -sym2js (FSymCat _ l n) = new "ArgProj" [JS.EInt n, JS.EInt l] -sym2js (FSymTok t) = new "Terminal" [JS.EStr t] - -new :: String -> [JS.Expr] -> JS.Expr -new f xs = JS.ENew (JS.Ident f) xs diff --git a/src-3.0/GF/GFCC/GFCCtoHaskell.hs b/src-3.0/GF/GFCC/GFCCtoHaskell.hs new file mode 100644 index 000000000..c29d88b1a --- /dev/null +++ b/src-3.0/GF/GFCC/GFCCtoHaskell.hs @@ -0,0 +1,212 @@ +---------------------------------------------------------------------- +-- | +-- Module : GFCCtoHaskell +-- Maintainer : Aarne Ranta +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/06/17 12:39:07 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.8 $ +-- +-- to write a GF abstract grammar into a Haskell module with translations from +-- data objects into GF trees. Example: GSyntax for Agda. +-- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 +----------------------------------------------------------------------------- + +module GF.GFCC.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where + +import GF.GFCC.Macros +import GF.GFCC.DataGFCC +import GF.GFCC.CId + +import GF.Data.Operations +import GF.Text.UTF8 + +import Data.List --(isPrefixOf, find, intersperse) +import qualified Data.Map as Map + +-- | the main function +grammar2haskell :: GFCC -> String +grammar2haskell gr = encodeUTF8 $ foldr (++++) [] $ + haskPreamble ++ [datatypes gr', gfinstances gr'] + where gr' = hSkeleton gr + +grammar2haskellGADT :: GFCC -> String +grammar2haskellGADT gr = encodeUTF8 $ foldr (++++) [] $ + ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ + haskPreamble ++ [datatypesGADT gr', gfinstances gr'] + where gr' = hSkeleton gr + +-- | by this you can prefix all identifiers with stg; the default is 'G' +gId :: OIdent -> OIdent +gId i = 'G':i + +haskPreamble = + [ + "module GSyntax where", + "", + "import GF.GFCC.DataGFCC", + "import GF.GFCC.CId", + "----------------------------------------------------", + "-- automatic translation from GF to Haskell", + "----------------------------------------------------", + "", + "class Gf a where", + " gf :: a -> Exp", + " fg :: Exp -> a", + "", + predefInst "GString" "String" "DTr [] (AS s) []", + "", + predefInst "GInt" "Integer" "DTr [] (AI s) []", + "", + predefInst "GFloat" "Double" "DTr [] (AF s) []", + "", + "----------------------------------------------------", + "-- below this line machine-generated", + "----------------------------------------------------", + "" + ] + +predefInst gtyp typ patt = + "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ + "instance Gf" +++ gtyp +++ "where" ++++ + " gf (" ++ gtyp +++ "s) =" +++ patt ++++ + " fg t =" ++++ + " case t of" ++++ + " " +++ patt +++ " ->" +++ gtyp +++ "s" ++++ + " _ -> error (\"no" +++ gtyp +++ "\" ++ show t)" + +type OIdent = String + +type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] + +datatypes, gfinstances :: (String,HSkeleton) -> String +datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd +gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g + +hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String +gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String + +hDatatype ("Cn",_) = "" --- +hDatatype (cat,[]) = "" +hDatatype (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ "deriving Show" +hDatatype (cat,rules) = + "data" +++ gId cat +++ "=" ++ + (if length rules == 1 then "" else "\n ") +++ + foldr1 (\x y -> x ++ "\n |" +++ y) + [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ + " deriving Show" + +-- GADT version of data types +datatypesGADT :: (String,HSkeleton) -> String +datatypesGADT (_,skel) = + unlines (concatMap hCatTypeGADT skel) + +++++ + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) + +hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hCatTypeGADT (cat,rules) + = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", + "data"+++gId cat++"_"] + +hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT (cat, rules) + | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] + | otherwise = + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] + where t = "Tree" +++ gId cat ++ "_" + +gfInstance m crs = hInstance m crs ++++ fInstance m crs + +----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 +hInstance m (cat,[]) = "" +hInstance m (cat,rules) + | isListCat (cat,rules) = + "instance Gf" +++ gId cat +++ "where" ++++ + " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] +-- no show for GADTs +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" + | otherwise = + "instance Gf" +++ gId cat +++ "where\n" ++ + unlines [mkInst f xx | (f,xx) <- rules] + where + ec = elemCat cat + baseVars = mkVars (baseSize (cat,rules)) + mkInst f xx = let xx' = mkVars (length xx) in " gf " ++ + (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ + "=" +++ mkRHS f xx' + mkVars n = ["x" ++ show i | i <- [1..n]] + mkRHS f vars = "DTr [] (AC (CId \"" ++ f ++ "\"))" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + + +----fInstance m ("Cn",_) = "" --- +fInstance m (cat,[]) = "" +fInstance m (cat,rules) = + " fg t =" ++++ + " case t of" ++++ + unlines [mkInst f xx | (f,xx) <- rules] ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ show t)" + where + mkInst f xx = + " DTr [] (AC (CId \"" ++ f ++ "\")) " ++ + "[" ++ prTList "," xx' ++ "]" +++ + "->" +++ mkRHS f xx' + where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isListCat (cat,rules) = + if "Base" `isPrefixOf` f then + gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else + let (i,t) = (init vars,last vars) + in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++ + gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"])) + | otherwise = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] + + +--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] +hSkeleton :: GFCC -> (String,HSkeleton) +hSkeleton gr = + (prCId (absname gr), + [(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) | + fs@((_, (_,c)):_) <- fns] + ) + where + fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr))))) + valtyps (_, (_,x)) (_, (_,y)) = compare x y + valtypg (_, (_,x)) (_, (_,y)) = x == y + jty (f,(ty,_)) = (f,catSkeleton ty) + +updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton +updateSkeleton cat skel rule = + case skel of + (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr + (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule + +isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool +isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where c = elemCat cat + fs = map fst rules + +-- | Gets the element category of a list category. +elemCat :: OIdent -> OIdent +elemCat = drop 4 + +isBaseFun :: OIdent -> Bool +isBaseFun f = "Base" `isPrefixOf` f + +isConsFun :: OIdent -> Bool +isConsFun f = "Cons" `isPrefixOf` f + +baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int +baseSize (_,rules) = length bs + where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules diff --git a/src-3.0/GF/GFCC/GFCCtoJS.hs b/src-3.0/GF/GFCC/GFCCtoJS.hs new file mode 100644 index 000000000..d32133ab2 --- /dev/null +++ b/src-3.0/GF/GFCC/GFCCtoJS.hs @@ -0,0 +1,132 @@ +module GF.GFCC.GFCCtoJS (gfcc2js) where + +import qualified GF.GFCC.Macros as M +import qualified GF.GFCC.DataGFCC as D +import GF.GFCC.CId +import qualified GF.JavaScript.AbsJS as JS +import qualified GF.JavaScript.PrintJS as JS + +import GF.Formalism.FCFG +import GF.Parsing.FCFG.PInfo +import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..)) + +import GF.Text.UTF8 +import GF.Data.ErrM +import GF.Infra.Option + +import Control.Monad (mplus) +import Data.Array (Array) +import qualified Data.Array as Array +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map + +gfcc2js :: D.GFCC -> String +gfcc2js gfcc = + encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] + where + n = prCId $ D.absname gfcc + as = D.abstract gfcc + cs = Map.assocs (D.concretes gfcc) + start = M.lookStartCat gfcc + grammar = new "GFGrammar" [abstract, concrete] + abstract = abstract2js start as + concrete = JS.EObj $ map (concrete2js start n) cs + +abstract2js :: String -> D.Abstr -> JS.Expr +abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (D.funs ds))] + +absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property +absdef2js (f,(typ,_)) = + let (args,cat) = M.catSkeleton typ in + JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)]) + +concrete2js :: String -> String -> (CId,D.Concr) -> JS.Property +concrete2js start n (c, cnc) = + JS.Prop l (new "GFConcrete" ([(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++ + maybe [] (parser2js start) (D.parser cnc))) + where + l = JS.IdentPropName (JS.Ident (prCId c)) + ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] + 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)]])] + + +cncdef2js :: String -> String -> (CId,D.Term) -> JS.Property +cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) + +term2js :: String -> String -> D.Term -> JS.Expr +term2js n l t = f t + where + f t = + case t of + 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 f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId 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 :: 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] + +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 = JS.Ident "cs" + +-- Parser +parser2js :: String -> FCFPInfo -> [JS.Expr] +parser2js start p = [new "Parser" [JS.EStr start, + JS.EArray $ map frule2js (Array.elems (allRules p)), + JS.EObj $ map cats (Map.assocs (startupCats p))]] + where + cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is)) + +frule2js :: FRule -> JS.Expr +frule2js (FRule n args res lins) = new "Rule" [JS.EInt res, name2js n, JS.EArray (map JS.EInt args), lins2js lins] + +name2js :: FName -> JS.Expr +name2js n = case n of + Name f [p] | f == wildCId -> fromProfile p + Name f ps -> new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] + where + fromProfile :: Profile (SyntaxForest CId) -> JS.Expr + fromProfile (Unify []) = new "MetaVar" [] + fromProfile (Unify [x]) = daughter x + fromProfile (Unify args) = new "Unify" [JS.EArray (map daughter args)] + fromProfile (Constant forest) = fromSyntaxForest forest + + daughter i = new "Arg" [JS.EInt i] + + fromSyntaxForest :: SyntaxForest CId -> JS.Expr + fromSyntaxForest FMeta = new "MetaVar" [] + -- FIXME: is there always just one element here? + fromSyntaxForest (FNode n [args]) = new "FunApp" $ [JS.EStr $ prCId n, JS.EArray (map fromSyntaxForest args)] + fromSyntaxForest (FString s) = new "Lit" $ [JS.EStr s] + fromSyntaxForest (FInt i) = new "Lit" $ [JS.EInt $ fromIntegral i] + fromSyntaxForest (FFloat f) = new "Lit" $ [JS.EDbl f] + +lins2js :: Array FIndex (Array FPointPos FSymbol) -> JS.Expr +lins2js ls = JS.EArray [ JS.EArray [ sym2js s | s <- Array.elems l] | l <- Array.elems ls] + +sym2js :: FSymbol -> JS.Expr +sym2js (FSymCat _ l n) = new "ArgProj" [JS.EInt n, JS.EInt l] +sym2js (FSymTok t) = new "Terminal" [JS.EStr t] + +new :: String -> [JS.Expr] -> JS.Expr +new f xs = JS.ENew (JS.Ident f) xs diff --git a/src-3.0/GF/GFCC/PrintGFCC.hs b/src-3.0/GF/GFCC/PrintGFCC.hs index d0dde05f4..aea34fb68 100644 --- a/src-3.0/GF/GFCC/PrintGFCC.hs +++ b/src-3.0/GF/GFCC/PrintGFCC.hs @@ -3,8 +3,8 @@ module GF.GFCC.PrintGFCC where 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 +import GF.GFCC.GFCCtoHaskell +import GF.GFCC.GFCCtoJS import GF.Text.UTF8 -- top-level access to code generation -- cgit v1.2.3