summaryrefslogtreecommitdiff
path: root/src/GF/GFCC/Raw/ConvertGFCC.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/GFCC/Raw/ConvertGFCC.hs')
-rw-r--r--src/GF/GFCC/Raw/ConvertGFCC.hs181
1 files changed, 159 insertions, 22 deletions
diff --git a/src/GF/GFCC/Raw/ConvertGFCC.hs b/src/GF/GFCC/Raw/ConvertGFCC.hs
index 325d6ea6d..0636cf5e1 100644
--- a/src/GF/GFCC/Raw/ConvertGFCC.hs
+++ b/src/GF/GFCC/Raw/ConvertGFCC.hs
@@ -3,8 +3,15 @@ module GF.GFCC.Raw.ConvertGFCC (toGFCC,fromGFCC) where
import GF.GFCC.DataGFCC
import GF.GFCC.Raw.AbsGFCCRaw
+import GF.Data.Assoc
+import GF.Formalism.FCFG
+import GF.Formalism.Utilities (NameProfile(..), Profile(..), SyntaxForest(..))
+import GF.Parsing.FCFG.PInfo (FCFPInfo(..))
+
+import qualified Data.Array as Array
import Data.Map
+
-- convert parsed grammar to internal GFCC
toGFCC :: Grammar -> GFCC
@@ -31,29 +38,88 @@ toGFCC (Grm [
catfuns = fromAscList
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
in Abstr aflags funs cats catfuns,
- concretes = fromAscList (lmap mkCnc ccs)
+ concretes = fromAscList [(lang, toConcr ts) | App lang ts <- ccs]
}
where
- mkCnc (
- App lang [
- App (CId "flags") fls,
- App (CId "lin") ls,
- App (CId "oper") ops,
- App (CId "lincat") lincs,
- App (CId "lindef") linds,
- App (CId "printname") prns,
- App (CId "param") params
- ]) = (lang,
- Concr {
- cflags = fromAscList [(f,v) | App f [AStr v] <- fls],
- lins = fromAscList [(f,toTerm v) | App f [v] <- ls],
- opers = fromAscList [(f,toTerm v) | App f [v] <- ops],
- lincats = fromAscList [(f,toTerm v) | App f [v] <- lincs],
- lindefs = fromAscList [(f,toTerm v) | App f [v] <- linds],
- printnames = fromAscList [(f,toTerm v) | App f [v] <- prns],
- paramlincats = fromAscList [(f,toTerm v) | App f [v] <- params]
- }
- )
+
+toConcr :: [RExp] -> Concr
+toConcr = foldl add (Concr {
+ cflags = empty,
+ lins = empty,
+ opers = empty,
+ lincats = empty,
+ lindefs = empty,
+ printnames = empty,
+ paramlincats = empty,
+ parser = Nothing
+ })
+ where
+ add :: Concr -> RExp -> Concr
+ add cnc (App (CId "flags") ts) = cnc { cflags = fromAscList [(f,v) | App f [AStr v] <- ts] }
+ add cnc (App (CId "lin") ts) = cnc { lins = mkTermMap ts }
+ add cnc (App (CId "oper") ts) = cnc { opers = mkTermMap ts }
+ add cnc (App (CId "lincat") ts) = cnc { lincats = mkTermMap ts }
+ add cnc (App (CId "lindef") ts) = cnc { lindefs = mkTermMap ts }
+ add cnc (App (CId "printname") ts) = cnc { printnames = mkTermMap ts }
+ add cnc (App (CId "param") ts) = cnc { paramlincats = mkTermMap ts }
+ add cnc (App (CId "parser") ts) = cnc { parser = Just (toPInfo ts) }
+
+toPInfo :: [RExp] -> FCFPInfo
+toPInfo = foldl add (FCFPInfo {
+ allRules = error "FCFPInfo.allRules",
+ topdownRules = error "FCFPInfo.topdownRules",
+ epsilonRules = error "FCFPInfo.epsilonRules",
+ leftcornerCats = error "FCFPInfo.leftcornerCats",
+ leftcornerTokens = error "FCFPInfo.leftcornerTokens",
+ grammarCats = error "FCFPInfo.grammarCats",
+ grammarToks = error "FCFPInfo.grammarToks",
+ startupCats = error "FCFPInfo.startupCats"})
+ where
+ add :: FCFPInfo -> RExp -> FCFPInfo
+ add p (App (CId f) ts) =
+ case f of
+ "rules" -> p { allRules = mkArray (lmap toFRule ts) }
+ "topdownrules" -> p { topdownRules = toAssoc expToInt (lmap expToInt) ts }
+ "epsilonrules" -> p { epsilonRules = lmap expToInt ts }
+ "lccats" -> p { leftcornerCats = toAssoc expToInt (lmap expToInt) ts }
+ "lctoks" -> p { leftcornerTokens = toAssoc expToStr (lmap expToInt) ts }
+ "cats" -> p { grammarCats = lmap expToInt ts }
+ "toks" -> p { grammarToks = lmap expToStr ts }
+ "startupcats" -> p { startupCats = fromList [(c, lmap expToInt cs) | App c cs <- ts] }
+ toFRule :: RExp -> FRule
+ toFRule (App (CId "rule")
+ [n,
+ App (CId "cats") (rt:at),
+ App (CId "R") ls]) = FRule name args res lins
+ where
+ name = toFName n
+ args = lmap expToInt at
+ res = expToInt rt
+ lins = mkArray [mkArray [toSymbol s | s <- l] | App (CId "S") l <- ls]
+
+toFName :: RExp -> FName
+toFName (App (CId "_A") [x]) = Name (CId "_") [Unify [expToInt x]]
+toFName (App f ts) = Name f (lmap toProfile ts)
+ where
+ toProfile :: RExp -> Profile (SyntaxForest CId)
+ toProfile AMet = Unify []
+ toProfile (App (CId "_A") [t]) = Unify [expToInt t]
+ toProfile (App (CId "_U") ts) = Unify [expToInt t | App (CId "_A") [t] <- ts]
+ toProfile t = Constant (toSyntaxForest t)
+
+ toSyntaxForest :: RExp -> SyntaxForest CId
+ toSyntaxForest AMet = FMeta
+ toSyntaxForest (App n ts) = FNode n [lmap toSyntaxForest ts]
+ toSyntaxForest (AStr s) = FString s
+ toSyntaxForest (AInt i) = FInt i
+ toSyntaxForest (AFlt f) = FFloat f
+
+toSymbol :: RExp -> FSymbol
+toSymbol (App (CId "proj") [c,n,l]) = FSymCat (expToInt c) (expToInt l) (expToInt n)
+toSymbol (AStr t) = FSymTok t
+
+toAssoc :: Ord a => (RExp -> a) -> ([RExp] -> b) -> [RExp] -> Assoc a b
+toAssoc f g xs = listAssoc [(f k, g v) | App (CId "map") (k:v) <- xs]
toType :: RExp -> Type
toType e = case e of
@@ -120,7 +186,7 @@ fromGFCC gfcc0 = Grm [
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)]
- ]
+ ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
fromType :: Type -> RExp
fromType e = case e of
@@ -163,3 +229,74 @@ fromTerm e = case e of
where
app = App . CId
str v = app "S" (lmap AStr v)
+
+-- ** Parsing info
+
+fromPInfo :: FCFPInfo -> RExp
+fromPInfo p = app "parser" [
+ app "rules" [fromFRule rule | rule <- Array.elems (allRules p)],
+ app "topdownrules" (fromAssoc intToExp (lmap intToExp) (topdownRules p)),
+ app "epsilonrules" (lmap intToExp (epsilonRules p)),
+ app "lccats" (fromAssoc intToExp (lmap intToExp) (leftcornerCats p)),
+ app "lctoks" (fromAssoc AStr (lmap intToExp) (leftcornerTokens p)),
+ app "cats" (lmap intToExp (grammarCats p)),
+ app "toks" (lmap AStr (grammarToks p)),
+ app "startupcats" [App f (lmap intToExp cs) | (f,cs) <- toList (startupCats p)]
+ ]
+
+fromAssoc :: Ord a => (a -> RExp) -> (b -> [RExp]) -> Assoc a b -> [RExp]
+fromAssoc f g xs = [app "map" (f x:g y) | (x,y) <- aAssocs xs]
+
+fromFRule :: FRule -> RExp
+fromFRule (FRule n args res lins) =
+ app "rule" [fromFName n,
+ app "cats" (intToExp res:lmap intToExp args),
+ app "R" [app "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
+ ]
+
+fromFName :: FName -> RExp
+fromFName n = case n of
+ Name (CId "_") [p] -> fromProfile p
+ Name f ps -> App f (lmap fromProfile ps)
+ where
+ fromProfile :: Profile (SyntaxForest CId) -> RExp
+ fromProfile (Unify []) = AMet
+ fromProfile (Unify [x]) = daughter x
+ fromProfile (Unify args) = app "_U" (lmap daughter args)
+ fromProfile (Constant forest) = fromSyntaxForest forest
+
+ daughter n = app "_A" [intToExp n]
+
+ fromSyntaxForest :: SyntaxForest CId -> RExp
+ fromSyntaxForest FMeta = AMet
+ -- FIXME: is there always just one element here?
+ fromSyntaxForest (FNode n [args]) = App n (lmap fromSyntaxForest args)
+ fromSyntaxForest (FString s) = AStr s
+ fromSyntaxForest (FInt i) = AInt i
+ fromSyntaxForest (FFloat f) = AFlt f
+
+fromSymbol :: FSymbol -> RExp
+fromSymbol (FSymCat c l n) = app "proj" [intToExp c, intToExp n, intToExp l]
+fromSymbol (FSymTok t) = AStr t
+
+-- ** Utilities
+
+mkTermMap :: [RExp] -> Map CId Term
+mkTermMap ts = fromAscList [(f,toTerm v) | App f [v] <- ts]
+
+app :: String -> [RExp] -> RExp
+app = App . CId
+
+mkArray :: [a] -> Array.Array Int a
+mkArray xs = Array.listArray (0, length xs - 1) xs
+
+expToInt :: Integral a => RExp -> a
+expToInt (App (CId "neg") [AInt i]) = fromIntegral (negate i)
+expToInt (AInt i) = fromIntegral i
+
+expToStr :: RExp -> String
+expToStr (AStr s) = s
+
+intToExp :: Integral a => a -> RExp
+intToExp x | x < 0 = App (CId "neg") [AInt (fromIntegral (negate x))]
+ | otherwise = AInt (fromIntegral x)
generated by cgit v1.2.3 (git 2.39.1) at 2026-06-19 05:58:04 +0000