GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-23 09:52:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

Use canonical GF in LPGF compiler

Browse Source 
Still contains some hardcoded values, missing cases.

I notice now that LPGF and Canonical GF are almost identical, so maybe we don't need a new LPGF format,
just a linearization-only runtime which works on canonical grammars.
The argument for keeping LGPF is that it would be optimized for size and speed.
This commit is contained in:
John J. Camilleri
2021-02-01 12:28:06 +01:00
parent cead0cc4c1
commit fe15aa0c00
5 changed files with 137 additions and 111 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -17,7 +17,7 @@ import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef) import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..)) import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
import GF.Infra.Option(optionsPGF) import GF.Infra.Option(Options, optionsPGF)
import PGF.Internal(Literal(..)) import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import GF.Grammar.Canonical as C import GF.Grammar.Canonical as C
@@ -25,6 +25,7 @@ import Debug.Trace
-- | Generate Canonical code for the named abstract syntax and all associated -- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes -- concrete syntaxes
grammar2canonical :: Options -> ModuleName -> SourceGrammar -> C.Grammar
grammar2canonical opts absname gr = grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr) Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr)) (map snd (concretes2canonical opts absname gr))

188
src/compiler/GF/Compile/GrammarToLPGF.hs
View File

@@ -4,134 +4,146 @@ import LPGF (LPGF (..))
import qualified LPGF as L import qualified LPGF as L
import PGF.CId import PGF.CId
import GF.Grammar.Predef -- import GF.Grammar.Predef
import GF.Grammar.Grammar import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look -- import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar as A -- import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM -- import qualified GF.Grammar.Macros as GM
import qualified GF.Grammar.Canonical as C
import GF.Compile.GrammarToCanonical (grammar2canonical)
import GF.Infra.Ident import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.UseIO (IOE) import GF.Infra.UseIO (IOE)
import GF.Data.Operations -- import GF.Data.Operations
import Control.Monad (forM_) -- import Control.Monad (forM_)
import Data.Either (lefts, rights)
import Data.List (elemIndex) import Data.List (elemIndex)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe (mapMaybe) import Data.Maybe (catMaybes)
import Text.Printf (printf)
mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
mkCanon2lpgf opts gr am = do mkCanon2lpgf opts gr am = do
(an,abs) <- mkAbstr am let grcn@(C.Grammar ab cncs) = grammar2canonical opts am gr
cncs <- mapM mkConcr (allConcretes gr am) (an,abs) <- mkAbstr ab
return $ LPGF { cncs <- mapM mkConcr cncs
let lpgf = LPGF {
L.absname = an, L.absname = an,
L.abstract = abs, L.abstract = abs,
L.concretes = Map.fromList cncs L.concretes = Map.fromList cncs
} }
print lpgf
return lpgf
where where
mkAbstr :: ModuleName -> IOE (CId, L.Abstr) mkAbstr :: C.Abstract -> IOE (CId, L.Abstr)
mkAbstr am = do mkAbstr (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstr {})
let
adefs =
[((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
Look.allOrigInfos gr am
-- funs = Map.fromList [ (i2i f, mkType [] ty) mkConcr :: C.Concrete -> IOE (CId, L.Concr)
-- | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs mkConcr (C.Concrete modId absModId flags params lincats lindefs) = do
-- , let arity = mkArity ma mdef ty -- print modId
-- ] -- print absModId
-- -- print flags
-- cats = Map.fromList [ (i2i c, ()) -- print params
-- | ((m,c),AbsCat (Just (L _ cont))) <- adefs -- print lincats
-- ] -- print lindefs
return (mi2i am, L.Abstr {
-- L.cats = cats,
-- L.funs = funs
})
mkConcr :: ModuleName -> IOE (CId, L.Concr)
mkConcr cm = do
let let
js = fromErr [] $ do es = map mkLin lindefs
mo <- lookupModule gr cm lins = Map.fromList $ rights es
-- return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [Look.lookupOrigInfo gr (cm,c)]]
return $ Map.toList (jments mo)
-- lincats = Map.fromList [] mkLin :: C.LinDef -> Either String (CId, L.LinFun)
lins = Map.fromList $ mapMaybe mkLin js mkLin ld@(C.LinDef funId varIds linValue) = do
lf <- val2lin varIds linValue
return (fi2i funId, lf)
mkLin :: (Ident, Info) -> Maybe (CId, L.LinFun) val2lin :: [C.VarId] -> C.LinValue -> Either String L.LinFun
mkLin (i, info) = case info of val2lin vids lv = case lv of
CncFun typ def@(Just (L (Local n _) term)) pn pmcfg -> do
lin <- term2lin [] Nothing term
return (i2i i, lin)
_ -> Nothing
term2lin :: [Ident] -> Maybe Type -> Term -> Maybe L.LinFun C.ConcatValue v1 v2 -> do
term2lin cxt mtype t = case t of v1' <- val2lin vids v1
-- abstraction: x -> b v2' <- val2lin vids v2
Abs Explicit arg term -> term2lin (arg:cxt) mtype term return $ L.LFConcat v1' v2'
-- concatenation: s ++ t C.LiteralValue ll -> case ll of
C t1 t2 -> do C.FloatConstant f -> return $ L.LFToken (show f)
t1' <- term2lin cxt Nothing t1 C.IntConstant i -> return $ L.LFToken (show i) -- LFInt ?
t2' <- term2lin cxt Nothing t2 C.StrConstant s -> return $ L.LFToken s
return $ L.LFConcat t1' t2'
-- string literal or token: "foo" C.ErrorValue err -> return $ L.LFError err
K s -> Just $ L.LFToken s
-- variable C.ParamConstant p@(C.Param (C.ParamId (C.Qual _ _)) _) -> do
Vr arg -> do let
ix <- elemIndex arg (reverse cxt) mixs =
return $ L.LFArgument (ix+1) [ elemIndex p pvs
| C.ParamDef pid pvds <- params
, let pvs = map (\(C.Param pid []) -> C.Param pid []) pvds -- TODO assumption of [] probably wrong
] -- look in all paramdefs
case catMaybes mixs of
ix:_ -> return $ L.LFInt (ix+1)
_ -> Left $ printf "Cannot find param value: %s" (show p)
-- record: { p = a ; ... } -- PredefValue PredefId -- TODO predef not supported
R asgns -> do
ts <- sequence [ term2lin cxt mtype term | (_, (mtype, term)) <- asgns ] C.RecordValue rrvs -> do
ts <- sequence [ val2lin vids lv | C.RecordRow lid lv <- rrvs ]
return $ L.LFTuple ts return $ L.LFTuple ts
-- qualified constructor from a package C.TableValue lt trvs -> do
QC qiV -> do ts <- sequence [ val2lin vids lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs
QC qiP <- mtype return $ L.LFTuple ts
let vs = [ ic | QC ic <- fromErr [] $ Look.lookupParamValues gr qiP ]
ix <- elemIndex qiV vs
return $ L.LFInt (ix+1)
-- projection: r.p C.TupleValue lvs -> do
P term lbl -> do ts <- mapM (val2lin vids) lvs
t <- term2lin cxt mtype term return $ L.LFTuple ts
let ix = 0 -- TODO need type of t to lookup this
return $ L.LFProjection t (L.LFInt (ix+1))
-- selection: t ! p C.VariantValue [] -> return L.LFEmpty
S t1 t2 -> do -- TODO C.VariantValue (vr:_) -> val2lin vids vr -- TODO variants not supported, just pick first
t1' <- term2lin cxt mtype t1
t2' <- term2lin cxt mtype t2
return $ L.LFProjection t1' t2'
_ -> Nothing C.VarValue (C.VarValueId (C.Unqual v)) -> do
ix <- eitherElemIndex (C.VarId v) vids
return $ L.LFArgument (ix+1)
return (mi2i cm, L.Concr { -- PreValue [([String], LinValue)] LinValue -- TODO pre not supported
C.Projection v1 (C.LabelId lbl) -> do
v1' <- val2lin vids v1
let lblIx = case lbl of -- TODO
"s" -> 0
"n" -> 1
"p" -> 2
return $ L.LFProjection v1' (L.LFInt (lblIx+1))
C.Selection v1 v2 -> do
v1' <- val2lin vids v1
v2' <- val2lin vids v2
return $ L.LFProjection v1' v2'
C.CommentedValue cmnt lv -> val2lin vids lv
v -> Left $ printf "val2lin not implemented for: %s" (show v)
mapM_ putStrLn (lefts es)
return (mdi2i modId, L.Concr {
-- L.lincats = lincats, -- L.lincats = lincats,
L.lins = lins L.lins = lins
}) })
eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
eitherElemIndex x xs = case elemIndex x xs of
Just ix -> Right ix
Nothing -> Left $ printf "Cannot find: %s" (show x)
i2i :: Ident -> CId i2i :: Ident -> CId
i2i = utf8CId . ident2utf8 i2i = utf8CId . ident2utf8
mi2i :: ModuleName -> CId mi2i :: ModuleName -> CId
mi2i (MN i) = i2i i mi2i (MN i) = i2i i
-- mkType :: [Ident] -> A.Type -> L.Type mdi2i :: C.ModId -> CId
-- mkType scope t = mdi2i (C.ModId i) = mkCId i
-- case GM.typeForm t of
-- (hyps,(_,cat),args) -> L.Type (map (\(bt,i,t) -> i2i i) hyps) (i2i cat)
-- mkArity (Just a) _ ty = a -- known arity, i.e. defined function fi2i :: C.FunId -> CId
-- mkArity Nothing (Just _) ty = 0 -- defined function with no arity - must be an axiom fi2i (C.FunId i) = mkCId i
-- mkArity Nothing _ ty = let (ctxt, _, _) = GM.typeForm ty -- constructor
-- in length ctxt

4
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -30,7 +30,7 @@ data TypeApp = TypeApp CatId [Type] deriving Show
data TypeBinding = TypeBinding VarId Type deriving Show data TypeBinding = TypeBinding VarId Type deriving Show
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- ** Concreate syntax -- ** Concrete syntax
-- | Concrete Syntax -- | Concrete Syntax
data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef] data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -117,7 +117,7 @@ newtype ModId = ModId Id deriving (Eq,Ord,Show)
newtype CatId = CatId Id deriving (Eq,Ord,Show) newtype CatId = CatId Id deriving (Eq,Ord,Show)
newtype FunId = FunId Id deriving (Eq,Show) newtype FunId = FunId Id deriving (Eq,Show)
data VarId = Anonymous | VarId Id deriving Show data VarId = Anonymous | VarId Id deriving (Eq,Show)
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
type FlagName = Id type FlagName = Id

14
src/runtime/haskell/LPGF.hs
View File

@@ -44,7 +44,8 @@ data LinType =
-- | Linearisation function -- | Linearisation function
data LinFun = data LinFun =
LFEmpty LFError String
| LFEmpty
| LFToken String | LFToken String
| LFConcat LinFun LinFun | LFConcat LinFun LinFun
| LFInt Int | LFInt Int
@@ -125,6 +126,7 @@ type Context = [LinFun]
-- | Operational semantics, Table 2 -- | Operational semantics, Table 2
eval :: Context -> LinFun -> LinFun eval :: Context -> LinFun -> LinFun
eval cxt t = case t of eval cxt t = case t of
LFError err -> error err
LFEmpty -> LFEmpty LFEmpty -> LFEmpty
LFToken tok -> LFToken tok LFToken tok -> LFToken tok
LFConcat s t -> LFConcat v w LFConcat s t -> LFConcat v w
@@ -136,8 +138,14 @@ eval cxt t = case t of
where vs = map (eval cxt) ts where vs = map (eval cxt) ts
LFProjection t u -> vs !! (i-1) LFProjection t u -> vs !! (i-1)
where where
LFTuple vs = eval cxt t -- LFTuple vs = eval cxt t
LFInt i = eval cxt u -- LFInt i = eval cxt u
vs = case eval cxt t of
LFTuple vs -> vs
x -> error $ "ERROR expected LFTuple, got: " ++ show x
i = case eval cxt u of
LFInt j -> j
x -> error $ "ERROR expected LFInt, got: " ++ show x
LFArgument i -> cxt !! (i-1) LFArgument i -> cxt !! (i-1)
-- | Turn concrete syntax terms into an actual string -- | Turn concrete syntax terms into an actual string

13
testsuite/lpgf/run.hs
View File

@@ -18,6 +18,7 @@ main = do
-- Do some linearization -- Do some linearization
forM_ [tree1, tree2, tree3] $ \tree -> do forM_ [tree1, tree2, tree3] $ \tree -> do
putStrLn ""
putStrLn (showExpr [] tree) putStrLn (showExpr [] tree)
forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) -> forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) ->
printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree) printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree)
@@ -61,10 +62,12 @@ walking = LPGF {
-- ], -- ],
lins = Map.fromList [ lins = Map.fromList [
(mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]), (mkCId "And", mkConcat [LFArgument 1, LFToken "and", LFArgument 2]),
(mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]), -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))]),
(mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))]),
(mkCId "John", LFTuple [LFToken "John", LFInt 1]), (mkCId "John", LFTuple [LFToken "John", LFInt 1]),
(mkCId "We", LFTuple [LFToken "we", LFInt 2]), (mkCId "We", LFTuple [LFToken "we", LFInt 2]),
(mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"]) -- (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"])
(mkCId "Walk", LFTuple [LFTuple [LFToken "walks", LFToken "walk"]])
] ]
}), }),
(mkCId "WalkingGer", Concr { (mkCId "WalkingGer", Concr {
@@ -75,10 +78,12 @@ walking = LPGF {
-- ], -- ],
lins = Map.fromList [ lins = Map.fromList [
(mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]), (mkCId "And", mkConcat [LFArgument 1, LFToken "und", LFArgument 2]),
(mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]), -- (mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFArgument 2) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
(mkCId "Pred", mkConcat [LFProjection (LFArgument 1) (LFInt 1), LFProjection (LFProjection (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))) (LFProjection (LFArgument 1) (LFInt 3))]),
(mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]), (mkCId "John", LFTuple [LFToken "John", LFInt 1, LFInt 3]),
(mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]), (mkCId "We", LFTuple [LFToken "wir", LFInt 2, LFInt 1]),
(mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]) -- (mkCId "Walk", LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]])
(mkCId "Walk", LFTuple [LFTuple [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]])
] ]
}) })
] ]