diff options
Diffstat (limited to 'src-3.0')
| -rw-r--r-- | src-3.0/GF/Compile/GenerateFCFG.hs | 14 | ||||
| -rw-r--r-- | src-3.0/GF/Formalism/FCFG.hs | 99 | ||||
| -rw-r--r-- | src-3.0/GF/GFCC/DataGFCC.hs | 100 | ||||
| -rw-r--r-- | src-3.0/GF/GFCC/GFCCtoJS.hs | 63 | ||||
| -rw-r--r-- | src-3.0/GF/GFCC/Linearize.hs | 24 | ||||
| -rw-r--r-- | src-3.0/GF/GFCC/Macros.hs | 17 | ||||
| -rw-r--r-- | src-3.0/GF/GFCC/Raw/ConvertGFCC.hs | 105 | ||||
| -rw-r--r-- | src-3.0/GF/Parsing/FCFG.hs | 1 | ||||
| -rw-r--r-- | src-3.0/GF/Parsing/FCFG/Active.hs | 2 | ||||
| -rw-r--r-- | src-3.0/GF/Parsing/FCFG/PInfo.hs | 20 |
10 files changed, 177 insertions, 268 deletions
diff --git a/src-3.0/GF/Compile/GenerateFCFG.hs b/src-3.0/GF/Compile/GenerateFCFG.hs index 7fc75987f..7571cae1a 100644 --- a/src-3.0/GF/Compile/GenerateFCFG.hs +++ b/src-3.0/GF/Compile/GenerateFCFG.hs @@ -20,7 +20,6 @@ import GF.Infra.PrintClass import Control.Monad import GF.Formalism.Utilities -import GF.Formalism.FCFG import GF.GFCC.Macros --hiding (prt) import GF.GFCC.DataGFCC @@ -76,7 +75,7 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, -- lincat for the _Var category varLincat = Map.singleton varCat (R [S []]) - lincatOf c = fromMaybe (error $ "No lincat for " ++ prt c) $ Map.lookup c lincats + lincatOf c = fromMaybe (error $ "No lincat for " ++ prCId c) $ Map.lookup c lincats modifyRec :: ([Term] -> [Term]) -> Term -> Term modifyRec f (R xs) = R (f xs) @@ -86,13 +85,13 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns, catName :: (Int,CId) -> CId catName (0,c) = c - catName (n,c) = mkCId ("_" ++ show n ++ prt c) + catName (n,c) = mkCId ("_" ++ show n ++ prCId c) funName :: (Int,CId) -> CId - funName (n,c) = mkCId ("__" ++ show n ++ prt c) + funName (n,c) = mkCId ("__" ++ show n ++ prCId c) varFunName :: CId -> CId - varFunName c = mkCId ("_Var_" ++ prt c) + varFunName c = mkCId ("_Var_" ++ prCId c) -- replaces __NCat with _B and _Var_Cat with _. -- the temporary names are just there to avoid name collisions. @@ -176,6 +175,7 @@ translateLin idxArgs lbl' ((lbl,syms) : lins) type CnvMonad a = BacktrackM Env a +type FPath = [FIndex] type Env = (ProtoFCat, [(ProtoFCat,[FPath])], Term, [Term]) type LinRec = [(FPath, [Either (FPath, FIndex, Int) FToken])] @@ -369,7 +369,7 @@ genFCatArg cnc_defs ctype env@(FRulesEnv last_id fcatSet rules) (PFCat cat rcs t addConstraint path0 index0 cs = (path0,index0) : cs gen_tcs (F id) path acc = case Map.lookup id cnc_defs of Just term -> gen_tcs term path acc - Nothing -> error ("unknown identifier: "++prt id) + Nothing -> error ("unknown identifier: "++prCId id) @@ -427,7 +427,7 @@ mkSingletonSelectors cnc_defs term = sels0 loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss) loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of Just term -> loop path (sels,tcss) term - Nothing -> error ("unknown identifier: "++prt id) + Nothing -> error ("unknown identifier: "++prCId id) mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector mkSelector rcs tcss = diff --git a/src-3.0/GF/Formalism/FCFG.hs b/src-3.0/GF/Formalism/FCFG.hs deleted file mode 100644 index 91f954aca..000000000 --- a/src-3.0/GF/Formalism/FCFG.hs +++ /dev/null @@ -1,99 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Definitions of fast multiple context-free grammars ------------------------------------------------------------------------------ - -module GF.Formalism.FCFG - ( - -- * Token - FToken - - -- * Category - , FPath - , FCat - - , fcatString, fcatInt, fcatFloat, fcatVar - - -- * Symbol - , FIndex - , FSymbol(..) - - -- * Grammar - , Profile - , FPointPos - , FGrammar - , FRule(..) - ) where - -import Control.Monad (liftM) -import Data.List (groupBy) -import Data.Array -import qualified Data.Map as Map - -import GF.Formalism.Utilities -import GF.GFCC.CId -import GF.Infra.PrintClass - ------------------------------------------------------------- --- Token -type FToken = String - - ------------------------------------------------------------- --- Category -type FPath = [FIndex] -type FCat = Int - -fcatString, fcatInt, fcatFloat, fcatVar :: Int -fcatString = (-1) -fcatInt = (-2) -fcatFloat = (-3) -fcatVar = (-4) - - ------------------------------------------------------------- --- Symbol -type FIndex = Int -data FSymbol - = FSymCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int - | FSymTok FToken - - ------------------------------------------------------------- --- Grammar - -type Profile = [Int] -type FPointPos = Int -type FGrammar = ([FRule], Map.Map CId [FCat]) -data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) - ------------------------------------------------------------- --- pretty-printing - -instance Print CId where - prt = prCId - -instance Print FSymbol where - prt (FSymCat l n) = "($" ++ prt n ++ "!" ++ prt l ++ ")" - prt (FSymTok t) = simpleShow (prt t) - where simpleShow str = "\"" ++ concatMap mkEsc str ++ "\"" - mkEsc '\\' = "\\\\" - mkEsc '\"' = "\\\"" - mkEsc '\n' = "\\n" - mkEsc '\t' = "\\t" - mkEsc chr = [chr] - prtList = prtSep " " - -instance Print FRule where - prt (FRule fun profile args res lins) = - prt fun ++ prtProf profile ++ " : " ++ (if null args then "" else prtSep " " args ++ " -> ") ++ prt res ++ - " =\n [" ++ prtSep "\n " ["("++prtSep " " [prt sym | (_,sym) <- assocs syms]++")" | (_,syms) <- assocs lins]++"]" - where - prtProf [] = "?" - prtProf args = prtSep "=" args - - prtList = prtSep "\n" diff --git a/src-3.0/GF/GFCC/DataGFCC.hs b/src-3.0/GF/GFCC/DataGFCC.hs index b4a2845fb..95a1c28ec 100644 --- a/src-3.0/GF/GFCC/DataGFCC.hs +++ b/src-3.0/GF/GFCC/DataGFCC.hs @@ -4,37 +4,37 @@ import GF.GFCC.CId import GF.Infra.PrintClass(prt) import GF.Infra.CompactPrint import GF.Text.UTF8 -import GF.Formalism.FCFG -import GF.Parsing.FCFG.PInfo +import GF.Data.Assoc -import Data.Map +import qualified Data.Map as Map import Data.List +import Data.Array -- internal datatypes for GFCC data GFCC = GFCC { absname :: CId , cncnames :: [CId] , - gflags :: Map CId String, -- value of a global flag + gflags :: Map.Map CId String, -- value of a global flag abstract :: Abstr , - concretes :: Map CId Concr + concretes :: Map.Map CId Concr } data Abstr = Abstr { - aflags :: Map CId String, -- value of a flag - funs :: Map CId (Type,Exp), -- type and def of a fun - cats :: Map CId [Hypo], -- context of a cat - catfuns :: Map CId [CId] -- funs to a cat (redundant, for fast lookup) + aflags :: Map.Map CId String, -- value of a flag + funs :: Map.Map CId (Type,Exp), -- type and def of a fun + cats :: Map.Map CId [Hypo], -- context of a cat + catfuns :: Map.Map CId [CId] -- funs to a cat (redundant, for fast lookup) } data Concr = Concr { - cflags :: Map CId String, -- value of a flag - lins :: Map CId Term, -- lin of a fun - opers :: Map CId Term, -- oper generated by subex elim - lincats :: Map CId Term, -- lin type of a cat - lindefs :: Map CId Term, -- lin default of a cat - printnames :: Map CId Term, -- printname of a cat or a fun - paramlincats :: Map CId Term, -- lin type of cat, with printable param names + cflags :: Map.Map CId String, -- value of a flag + lins :: Map.Map CId Term, -- lin of a fun + opers :: Map.Map CId Term, -- oper generated by subex elim + lincats :: Map.Map CId Term, -- lin type of a cat + lindefs :: Map.Map CId Term, -- lin default of a cat + printnames :: Map.Map CId Term, -- printname of a cat or a fun + paramlincats :: Map.Map CId Term, -- lin type of cat, with printable param names parser :: Maybe FCFPInfo -- parser } @@ -86,13 +86,50 @@ data Equation = Equ [Exp] Exp deriving (Eq,Ord,Show) + +type FToken = String +type FCat = Int +type FIndex = Int +data FSymbol + = FSymCat {-# UNPACK #-} !FIndex {-# UNPACK #-} !Int + | FSymTok FToken +type Profile = [Int] +type FPointPos = Int +type FGrammar = ([FRule], Map.Map CId [FCat]) +data FRule = FRule CId [Profile] [FCat] FCat (Array FIndex (Array FPointPos FSymbol)) + +type RuleId = Int + +data FCFPInfo + = FCFPInfo { allRules :: Array RuleId FRule + , topdownRules :: Assoc FCat [RuleId] + -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): + -- , emptyRules :: [RuleId] + , epsilonRules :: [RuleId] + -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): + , leftcornerCats :: Assoc FCat [RuleId] + , leftcornerTokens :: Assoc FToken [RuleId] + -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): + , grammarCats :: [FCat] + , grammarToks :: [FToken] + , startupCats :: Map.Map CId [FCat] + } + + +fcatString, fcatInt, fcatFloat, fcatVar :: Int +fcatString = (-1) +fcatInt = (-2) +fcatFloat = (-3) +fcatVar = (-4) + + -- print statistics statGFCC :: GFCC -> String statGFCC gfcc = unlines [ - "Abstract\t" ++ prt (absname gfcc), - "Concretes\t" ++ unwords (lmap prt (cncnames gfcc)), - "Categories\t" ++ unwords (lmap prt (keys (cats (abstract gfcc)))) + "Abstract\t" ++ prCId (absname gfcc), + "Concretes\t" ++ unwords (map prCId (cncnames gfcc)), + "Categories\t" ++ unwords (map prCId (Map.keys (cats (abstract gfcc)))) ] -- merge two GFCCs; fails is differens absnames; priority to second arg @@ -101,8 +138,8 @@ unionGFCC :: GFCC -> GFCC -> GFCC unionGFCC one two = case absname one of n | n == wildCId -> two -- extending empty grammar | n == absname two -> one { -- extending grammar with same abstract - concretes = Data.Map.union (concretes two) (concretes one), - cncnames = Data.List.union (cncnames two) (cncnames one) + concretes = Map.union (concretes two) (concretes one), + cncnames = union (cncnames two) (cncnames one) } _ -> one -- abstracts don't match ---- print error msg @@ -110,26 +147,21 @@ emptyGFCC :: GFCC emptyGFCC = GFCC { absname = wildCId, cncnames = [] , - gflags = empty, + gflags = Map.empty, abstract = error "empty grammar, no abstract", - concretes = empty + concretes = Map.empty } --- default map and filter are for Map here -lmap = Prelude.map -lfilter = Prelude.filter -mmap = Data.Map.map - -- encode idenfifiers and strings in UTF8 utf8GFCC :: GFCC -> GFCC utf8GFCC gfcc = gfcc { - concretes = mmap u8concr (concretes gfcc) + concretes = Map.map u8concr (concretes gfcc) } where u8concr cnc = cnc { - lins = mmap u8term (lins cnc), - opers = mmap u8term (opers cnc) + lins = Map.map u8term (lins cnc), + opers = Map.map u8term (opers cnc) } u8term = convertStringsInTerm encodeUTF8 @@ -138,9 +170,9 @@ utf8GFCC gfcc = gfcc { convertStringsInTerm conv t = case t of K (KS s) -> K (KS (conv s)) W s r -> W (conv s) (convs r) - R ts -> R $ lmap convs ts - S ts -> S $ lmap convs ts - FV ts -> FV $ lmap convs ts + R ts -> R $ map convs ts + S ts -> S $ map convs ts + FV ts -> FV $ map convs ts P u v -> P (convs u) (convs v) _ -> t where diff --git a/src-3.0/GF/GFCC/GFCCtoJS.hs b/src-3.0/GF/GFCC/GFCCtoJS.hs index e55655796..f0b19ba09 100644 --- a/src-3.0/GF/GFCC/GFCCtoJS.hs +++ b/src-3.0/GF/GFCC/GFCCtoJS.hs @@ -1,14 +1,11 @@ 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 GF.GFCC.DataGFCC 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.Text.UTF8 import GF.Data.ErrM import GF.Infra.Option @@ -19,60 +16,60 @@ import qualified Data.Array as Array import Data.Maybe (fromMaybe) import qualified Data.Map as Map -gfcc2js :: D.GFCC -> String +gfcc2js :: 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) + n = prCId $ absname gfcc + as = abstract gfcc + cs = Map.assocs (concretes gfcc) start = M.lookStartCat gfcc - grammar = new "GFGrammar" [abstract, concrete] - abstract = abstract2js start as - concrete = JS.EObj $ map (concrete2js start n) cs + grammar = new "GFGrammar" [js_abstract, js_concrete] + js_abstract = abstract2js start as + js_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))] +abstract2js :: String -> Abstr -> JS.Expr +abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] -absdef2js :: (CId,(D.Type,D.Exp)) -> JS.Property +absdef2js :: (CId,(Type,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 :: String -> String -> (CId,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))) + maybe [] (parser2js start) (parser cnc))) where l = JS.IdentPropName (JS.Ident (prCId c)) - ds = concatMap Map.assocs [D.lins cnc, D.opers cnc, D.lindefs cnc] + ds = concatMap Map.assocs [lins cnc, opers cnc, 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 :: String -> String -> (CId,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 :: String -> String -> 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.TM _ -> new "Meta" [] - -tokn2js :: D.Tokn -> JS.Expr -tokn2js (D.KS s) = mkStr s -tokn2js (D.KP ss vs) = mkSeq (map mkStr ss) -- FIXME + R xs -> new "Arr" (map f xs) + P x y -> JS.ECall (JS.EMember (f x) (JS.Ident "sel")) [f y] + S xs -> mkSeq (map f xs) + K t -> tokn2js t + V i -> JS.EIndex (JS.EVar children) (JS.EInt i) + C i -> new "Int" [JS.EInt i] + 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] + FV xs -> new "Variants" (map f xs) + W str x -> new "Suffix" [JS.EStr str, f x] + TM _ -> new "Meta" [] + +tokn2js :: Tokn -> JS.Expr +tokn2js (KS s) = mkStr s +tokn2js (KP ss vs) = mkSeq (map mkStr ss) -- FIXME mkStr :: String -> JS.Expr mkStr s = new "Str" [JS.EStr s] diff --git a/src-3.0/GF/GFCC/Linearize.hs b/src-3.0/GF/GFCC/Linearize.hs index 1888302d2..35f9abb43 100644 --- a/src-3.0/GF/GFCC/Linearize.hs +++ b/src-3.0/GF/GFCC/Linearize.hs @@ -4,7 +4,7 @@ import GF.GFCC.Macros import GF.GFCC.DataGFCC import GF.GFCC.CId import GF.Infra.PrintClass -import Data.Map +import qualified Data.Map as Map import Data.List import Debug.Trace @@ -17,7 +17,7 @@ linearize mcfg lang = realize . linExp mcfg lang realize :: Term -> String realize trm = case trm of R ts -> realize (ts !! 0) - S ss -> unwords $ lmap realize ss + S ss -> unwords $ map realize ss K t -> case t of KS s -> s KP s _ -> unwords s ---- prefix choice TODO @@ -29,13 +29,13 @@ realize trm = case trm of linExp :: GFCC -> CId -> Exp -> Term linExp mcfg lang tree@(DTr xs at trees) = addB $ case at of - AC fun -> comp (lmap lin trees) $ look fun + AC fun -> comp (map lin trees) $ look fun AS s -> R [kks (show s)] -- quoted AI i -> R [kks (show i)] --- [C lst, kks (show i), C size] where --- lst = mod (fromInteger i) 10 ; size = if i < 10 then 0 else 1 AF d -> R [kks (show d)] - AV x -> TM (prt x) + AV x -> TM (prCId x) AM i -> TM (show i) where lin = linExp mcfg lang @@ -44,31 +44,31 @@ linExp mcfg lang tree@(DTr xs at trees) = addB t | Data.List.null xs = t | otherwise = case t of - R ts -> R $ ts ++ (Data.List.map (kks . prt) xs) - TM s -> R $ t : (Data.List.map (kks . prt) xs) + R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) + TM s -> R $ t : (Data.List.map (kks . prCId) xs) compute :: GFCC -> CId -> [Term] -> Term -> Term compute mcfg lang args = comp where comp trm = case trm of P r p -> proj (comp r) (comp p) W s t -> W s (comp t) - R ts -> R $ lmap comp ts + R ts -> R $ map comp ts V i -> idx args i -- already computed F c -> comp $ look c -- not computed (if contains argvar) - FV ts -> FV $ lmap comp ts - S ts -> S $ lfilter (/= S []) $ lmap comp ts + FV ts -> FV $ map comp ts + S ts -> S $ filter (/= S []) $ map comp ts _ -> trm look = lookOper mcfg lang idx xs i = if i > length xs - 1 then trace - ("too large " ++ show i ++ " for\n" ++ unlines (lmap show xs) ++ "\n") tm0 + ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0 else xs !! i proj r p = case (r,p) of - (_, FV ts) -> FV $ lmap (proj r) ts - (FV ts, _ ) -> FV $ lmap (\t -> proj t p) ts + (_, FV ts) -> FV $ map (proj r) ts + (FV ts, _ ) -> FV $ map (\t -> proj t p) ts (W s t, _) -> kks (s ++ getString (proj t p)) _ -> comp $ getField r (getIndex p) diff --git a/src-3.0/GF/GFCC/Macros.hs b/src-3.0/GF/GFCC/Macros.hs index 5eaa4bdb3..85a92523a 100644 --- a/src-3.0/GF/GFCC/Macros.hs +++ b/src-3.0/GF/GFCC/Macros.hs @@ -2,11 +2,10 @@ module GF.GFCC.Macros where import GF.GFCC.CId import GF.GFCC.DataGFCC -import GF.Formalism.FCFG (FGrammar) -import GF.Parsing.FCFG.PInfo (FCFPInfo, fcfPInfoToFGrammar) +import GF.Parsing.FCFG.PInfo (fcfPInfoToFGrammar) import GF.Infra.PrintClass import Control.Monad -import Data.Map +import qualified Data.Map as Map import Data.Maybe import Data.List @@ -39,7 +38,7 @@ lookFCFG :: GFCC -> CId -> Maybe FGrammar lookFCFG gfcc lang = fmap fcfPInfoToFGrammar $ lookParser gfcc lang lookStartCat :: GFCC -> String -lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Data.Map.lookup (mkCId "startcat")) +lookStartCat gfcc = fromMaybe "S" $ msum $ Data.List.map (Map.lookup (mkCId "startcat")) [gflags gfcc, aflags (abstract gfcc)] lookGlobalFlag :: GFCC -> CId -> String @@ -56,14 +55,14 @@ lookCncFlag gfcc lang f = functionsToCat :: GFCC -> CId -> [(CId,Type)] functionsToCat gfcc cat = - [(f,ty) | f <- fs, Just (ty,_) <- [Data.Map.lookup f $ funs $ abstract gfcc]] + [(f,ty) | f <- fs, Just (ty,_) <- [Map.lookup f $ funs $ abstract gfcc]] where fs = lookMap [] cat $ catfuns $ abstract gfcc depth :: Exp -> Int depth tr = case tr of DTr _ _ [] -> 1 - DTr _ _ ts -> maximum (lmap depth ts) + 1 + DTr _ _ ts -> maximum (map depth ts) + 1 tree :: Atom -> [Exp] -> Exp tree = DTr [] @@ -94,7 +93,7 @@ primNotion :: Exp primNotion = EEq [] term0 :: CId -> Term -term0 = TM . prt +term0 = TM . prCId tm0 :: Term tm0 = TM "?" @@ -103,8 +102,8 @@ kks :: String -> Term kks = K . KS -- 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 +lookMap :: (Show i, Ord i) => a -> i -> Map.Map i a -> a +lookMap d c m = maybe d id $ Map.lookup c m --- from Operations combinations :: [[a]] -> [[a]] diff --git a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs index cebc06a31..73b362888 100644 --- a/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs +++ b/src-3.0/GF/GFCC/Raw/ConvertGFCC.hs @@ -5,12 +5,11 @@ import GF.GFCC.DataGFCC import GF.GFCC.Raw.AbsGFCCRaw import GF.Infra.PrintClass -import GF.Formalism.FCFG import GF.Formalism.Utilities -import GF.Parsing.FCFG.PInfo (FCFPInfo(..), buildFCFPInfo) +import GF.Parsing.FCFG.PInfo (buildFCFPInfo) import qualified Data.Array as Array -import Data.Map +import qualified Data.Map as Map pgfMajorVersion, pgfMinorVersion :: Integer (pgfMajorVersion, pgfMinorVersion) = (1,0) @@ -30,35 +29,35 @@ toGFCC (Grm [ ]) = GFCC { absname = mkCId a, cncnames = [mkCId c | App c [] <- cs], - gflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs], + gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs], abstract = let - aflags = fromAscList [(mkCId f,v) | App f [AStr v] <- gfs] + aflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs] lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs] - funs = fromAscList lfuns + funs = Map.fromAscList lfuns lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts] - cats = fromAscList lcats - catfuns = fromAscList + cats = Map.fromAscList lcats + catfuns = Map.fromAscList [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] in Abstr aflags funs cats catfuns, - concretes = fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs] + concretes = Map.fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs] } where toConcr :: [RExp] -> Concr toConcr = foldl add (Concr { - cflags = empty, - lins = empty, - opers = empty, - lincats = empty, - lindefs = empty, - printnames = empty, - paramlincats = empty, + cflags = Map.empty, + lins = Map.empty, + opers = Map.empty, + lincats = Map.empty, + lindefs = Map.empty, + printnames = Map.empty, + paramlincats = Map.empty, parser = Nothing }) where add :: Concr -> RExp -> Concr - add cnc (App "flags" ts) = cnc { cflags = fromAscList [(mkCId f,v) | App f [AStr v] <- ts] } + add cnc (App "flags" ts) = cnc { cflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- ts] } add cnc (App "lin" ts) = cnc { lins = mkTermMap ts } add cnc (App "oper" ts) = cnc { opers = mkTermMap ts } add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts } @@ -70,8 +69,8 @@ toConcr = foldl add (Concr { toPInfo :: [RExp] -> FCFPInfo toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats) where - rules = lmap toFRule rs - cats = fromList [(mkCId c, lmap expToInt fs) | App c fs <- cs] + rules = map toFRule rs + cats = Map.fromList [(mkCId c, map expToInt fs) | App c fs <- cs] toFRule :: RExp -> FRule toFRule (App "rule" @@ -80,13 +79,13 @@ toPInfo [App "rules" rs, App "startupcats" cs] = buildFCFPInfo (rules, cats) App "R" ls]) = FRule fun prof args res lins where (fun,prof) = toFName n - args = lmap expToInt at + args = map expToInt at res = expToInt rt lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls] toFName :: RExp -> (CId,[Profile]) toFName (App "_A" [x]) = (wildCId, [[expToInt x]]) -toFName (App f ts) = (mkCId f, lmap toProfile ts) +toFName (App f ts) = (mkCId f, map toProfile ts) where toProfile :: RExp -> Profile toProfile AMet = [] @@ -100,7 +99,7 @@ toSymbol (AStr t) = FSymTok t toType :: RExp -> Type toType e = case e of App cat [App "H" hypos, App "X" exps] -> - DTyp (lmap toHypo hypos) (mkCId cat) (lmap toExp exps) + DTyp (map toHypo hypos) (mkCId cat) (map toExp exps) _ -> error $ "type " ++ show e toHypo :: RExp -> Hypo @@ -111,9 +110,9 @@ toHypo e = case e of toExp :: RExp -> Exp toExp e = case e of App "App" [App fun [], App "B" xs, App "X" exps] -> - DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (lmap toExp exps) + DTr [mkCId x | App x [] <- xs] (AC (mkCId fun)) (map toExp exps) App "Eq" eqs -> - EEq [Equ (lmap toExp ps) (toExp v) | App "E" (v:ps) <- eqs] + EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs] App "Var" [App i []] -> DTr [] (AV (mkCId i)) [] AMet -> DTr [] (AM 0) [] AInt i -> DTr [] (AI i) [] @@ -123,9 +122,9 @@ toExp e = case e of toTerm :: RExp -> Term toTerm e = case e of - App "R" es -> R (lmap toTerm es) - App "S" es -> S (lmap toTerm es) - App "FV" es -> FV (lmap toTerm es) + App "R" es -> R (map toTerm es) + App "S" es -> S (map toTerm es) + App "FV" es -> FV (map toTerm es) App "P" [e,v] -> P (toTerm e) (toTerm v) App "W" [AStr s,v] -> W s (toTerm v) App "A" [AInt i] -> V (fromInteger i) @@ -142,33 +141,33 @@ toTerm e = case e of fromGFCC :: GFCC -> Grammar fromGFCC gfcc0 = Grm [ App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion - : App (prCId (absname gfcc)) [] : lmap (flip App [] . prCId) (cncnames gfcc)), - App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (gflags gfcc `union` aflags agfcc)], + : App (prCId (absname gfcc)) [] : map (flip App [] . prCId) (cncnames gfcc)), + App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags gfcc `Map.union` aflags agfcc)], App "abstract" [ - App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- toList (funs agfcc)], - App "cat" [App (prCId f) (lmap fromHypo hs) | (f,hs) <- toList (cats agfcc)] + App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs agfcc)], + App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats agfcc)] ], - App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- toList (concretes gfcc)] + App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes gfcc)] ] where gfcc = utf8GFCC gfcc0 agfcc = abstract gfcc fromConcrete cnc = [ - App "flags" [App (prCId f) [AStr v] | (f,v) <- toList (cflags cnc)], - App "lin" [App (prCId f) [fromTerm v] | (f,v) <- toList (lins cnc)], - App "oper" [App (prCId f) [fromTerm v] | (f,v) <- toList (opers cnc)], - App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- toList (lincats cnc)], - App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- toList (lindefs cnc)], - App "printname" [App (prCId f) [fromTerm v] | (f,v) <- toList (printnames cnc)], - App "param" [App (prCId f) [fromTerm v] | (f,v) <- toList (paramlincats cnc)] + App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)], + App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)], + App "oper" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)], + App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)], + App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)], + App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)], + App "param" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)] ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc) fromType :: Type -> RExp fromType e = case e of DTyp hypos cat exps -> App (prCId cat) [ - App "H" (lmap fromHypo hypos), - App "X" (lmap fromExp exps)] + App "H" (map fromHypo hypos), + App "X" (map fromExp exps)] fromHypo :: Hypo -> RExp fromHypo e = case e of @@ -177,21 +176,21 @@ fromHypo e = case e of fromExp :: Exp -> RExp fromExp e = case e of DTr xs (AC fun) exps -> - App "App" [App (prCId fun) [], App "B" (lmap (flip App [] . prCId) xs), App "X" (lmap fromExp exps)] + App "App" [App (prCId fun) [], App "B" (map (flip App [] . prCId) xs), App "X" (map fromExp exps)] DTr [] (AV x) [] -> App "Var" [App (prCId x) []] DTr [] (AS s) [] -> AStr s DTr [] (AF d) [] -> AFlt d DTr [] (AI i) [] -> AInt (toInteger i) DTr [] (AM _) [] -> AMet ---- EEq eqs -> - App "Eq" [App "E" (lmap fromExp (v:ps)) | Equ ps v <- eqs] + App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs] _ -> 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) + R es -> App "R" (map fromTerm es) + S es -> App "S" (map fromTerm es) + FV es -> App "FV" (map fromTerm es) P e v -> App "P" [fromTerm e, fromTerm v] W s v -> App "W" [AStr s, fromTerm v] C i -> AInt (toInteger i) @@ -201,31 +200,31 @@ fromTerm e = case e of K (KS s) -> AStr s ---- K (KP d vs) -> App "FV" (str d : [str v | Var v _ <- vs]) ---- where - str v = App "S" (lmap AStr v) + str v = App "S" (map AStr v) -- ** Parsing info fromPInfo :: FCFPInfo -> RExp fromPInfo p = App "parser" [ App "rules" [fromFRule rule | rule <- Array.elems (allRules p)], - App "startupcats" [App (prCId f) (lmap intToExp cs) | (f,cs) <- toList (startupCats p)] + App "startupcats" [App (prCId f) (map intToExp cs) | (f,cs) <- Map.toList (startupCats p)] ] fromFRule :: FRule -> RExp fromFRule (FRule fun prof args res lins) = App "rule" [fromFName (fun,prof), - App "cats" (intToExp res:lmap intToExp args), + App "cats" (intToExp res:map intToExp args), App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins] ] fromFName :: (CId,[Profile]) -> RExp fromFName (f,ps) | f == wildCId = fromProfile (head ps) - | otherwise = App (prCId f) (lmap fromProfile ps) + | otherwise = App (prCId f) (map fromProfile ps) where fromProfile :: Profile -> RExp fromProfile [] = AMet fromProfile [x] = daughter x - fromProfile args = App "_U" (lmap daughter args) + fromProfile args = App "_U" (map daughter args) daughter n = App "_A" [intToExp n] @@ -235,8 +234,8 @@ fromSymbol (FSymTok t) = AStr t -- ** Utilities -mkTermMap :: [RExp] -> Map CId Term -mkTermMap ts = fromAscList [(mkCId f,toTerm v) | App f [v] <- ts] +mkTermMap :: [RExp] -> Map.Map CId Term +mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts] mkArray :: [a] -> Array.Array Int a mkArray xs = Array.listArray (0, length xs - 1) xs diff --git a/src-3.0/GF/Parsing/FCFG.hs b/src-3.0/GF/Parsing/FCFG.hs index b279caf48..f0d172f18 100644 --- a/src-3.0/GF/Parsing/FCFG.hs +++ b/src-3.0/GF/Parsing/FCFG.hs @@ -15,7 +15,6 @@ import GF.Data.Assoc import GF.Infra.PrintClass -import GF.Formalism.FCFG import GF.Formalism.Utilities import qualified GF.Parsing.FCFG.Active as Active diff --git a/src-3.0/GF/Parsing/FCFG/Active.hs b/src-3.0/GF/Parsing/FCFG/Active.hs index 7db4fbb61..3b389f237 100644 --- a/src-3.0/GF/Parsing/FCFG/Active.hs +++ b/src-3.0/GF/Parsing/FCFG/Active.hs @@ -15,7 +15,7 @@ import GF.Data.SortedList import GF.Data.Utilities import GF.GFCC.CId -import GF.Formalism.FCFG +import GF.GFCC.DataGFCC import GF.Formalism.Utilities import GF.Infra.PrintClass diff --git a/src-3.0/GF/Parsing/FCFG/PInfo.hs b/src-3.0/GF/Parsing/FCFG/PInfo.hs index 2d6385feb..e151a5ac1 100644 --- a/src-3.0/GF/Parsing/FCFG/PInfo.hs +++ b/src-3.0/GF/Parsing/FCFG/PInfo.hs @@ -11,10 +11,10 @@ module GF.Parsing.FCFG.PInfo where import GF.Infra.PrintClass import GF.Formalism.Utilities -import GF.Formalism.FCFG import GF.Data.SortedList import GF.Data.Assoc import GF.GFCC.CId +import GF.GFCC.DataGFCC import Data.Array import Data.Maybe @@ -37,24 +37,6 @@ makeFinalEdge cat i j = (cat, [makeRange i j]) ------------------------------------------------------------ -- parser information -type RuleId = Int - -data FCFPInfo - = FCFPInfo { allRules :: Array RuleId FRule - , topdownRules :: Assoc FCat (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): - -- , emptyRules :: [RuleId] - , epsilonRules :: [RuleId] - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , leftcornerCats :: Assoc FCat (SList RuleId) - , leftcornerTokens :: Assoc FToken (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , grammarCats :: SList FCat - , grammarToks :: SList FToken - , startupCats :: Map.Map CId [FCat] - } - - getLeftCornerTok (FRule _ _ _ _ lins) | inRange (bounds syms) 0 = case syms ! 0 of FSymTok tok -> [tok] |