mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Replace list comprehension lookups with maps. Halfway through transitioning to new strategy for tables/params, see testsuite/lpgf/README.md.
This commit is contained in:
John J. Camilleri
@@ -51,9 +51,37 @@ mkCanon2lpgf opts gr am = do
|
||||
mkConcrete (C.Concrete modId absModId flags params' lincats lindefs) = do
|
||||
let
|
||||
(C.Abstract _ _ _ funs) = ab
|
||||
params = inlineParamAliases params' -- TODO remove by making mkParamTuples return map
|
||||
paramTuples = mkParamTuples params'
|
||||
let
|
||||
params = inlineParamAliases params'
|
||||
|
||||
-- Builds maps for lookups
|
||||
|
||||
paramValueMap :: Map.Map C.ParamId C.ParamDef -- constructor -> definition
|
||||
paramValueMap = Map.fromList [ (v,d) | d@(C.ParamDef _ vs) <- params, (C.Param v _) <- vs ]
|
||||
|
||||
lincatMap :: Map.Map C.CatId C.LincatDef
|
||||
lincatMap = Map.fromList [ (cid,d) | d@(C.LincatDef cid _) <- lincats ]
|
||||
|
||||
funMap :: Map.Map C.FunId C.FunDef
|
||||
funMap = Map.fromList [ (fid,d) | d@(C.FunDef fid _) <- funs ]
|
||||
|
||||
-- | Lookup lintype for a function
|
||||
lookupLinType :: C.FunId -> Either String C.LinType
|
||||
lookupLinType funId = do
|
||||
fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
|
||||
let (C.FunDef _ (C.Type _ (C.TypeApp catId _))) = fun
|
||||
lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
|
||||
let (C.LincatDef _ lt) = lincat
|
||||
return lt
|
||||
|
||||
-- | Lookup lintype for a function's argument
|
||||
lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType
|
||||
lookupLinTypeArg funId argIx = do
|
||||
fun <- m2e (printf "Cannot find type for: %s" (show funId)) (Map.lookup funId funMap)
|
||||
let (C.FunDef _ (C.Type args _)) = fun
|
||||
let (C.TypeBinding _ (C.Type _ (C.TypeApp catId _))) = args !! argIx
|
||||
lincat <- m2e (printf "Cannot find lincat for: %s" (show catId)) (Map.lookup catId lincatMap)
|
||||
let (C.LincatDef _ lt) = lincat
|
||||
return lt
|
||||
|
||||
-- filter out record fields from defn which don't appear in lincat
|
||||
-- this seems to be an inconsistency in the canonical representation
|
||||
@@ -69,19 +97,7 @@ mkCanon2lpgf opts gr am = do
|
||||
es = map mkLin lindefs'
|
||||
lins = Map.fromList $ rights es
|
||||
|
||||
-- | Lookup lintype for a function
|
||||
lookupLinType :: C.FunId -> Either String C.LinType
|
||||
lookupLinType funId = do
|
||||
(C.Type _ (C.TypeApp catId _)) <- [ ftype | C.FunDef fid ftype <- funs, fid == funId ] `headOrLeft` printf "Cannot find type for: %s" (show funId)
|
||||
[ lt | C.LincatDef cid lt <- lincats, cid == catId ] `headOrLeft` printf "Cannot find lincat for: %s" (show catId)
|
||||
|
||||
-- | Lookup lintype for a function's argument
|
||||
lookupLinTypeArg :: C.FunId -> Int -> Either String C.LinType
|
||||
lookupLinTypeArg funId argIx = do
|
||||
(C.Type args _) <- [ ftype | C.FunDef fid ftype <- funs, fid == funId ] `headOrLeft` printf "Cannot find type for: %s" (show funId)
|
||||
let C.TypeBinding _ (C.Type _ (C.TypeApp catId _)) = args !! argIx
|
||||
[ lt | C.LincatDef cid lt <- lincats, cid == catId ] `headOrLeft` printf "Cannot find lincat for: %s" (show catId)
|
||||
|
||||
-- | Main code generation function
|
||||
mkLin :: C.LinDef -> Either String (CId, L.LinFun)
|
||||
mkLin (C.LinDef funId varIds linValue) = do
|
||||
(lf, _) <- val2lin linValue
|
||||
@@ -102,14 +118,11 @@ mkCanon2lpgf opts gr am = do
|
||||
|
||||
C.ErrorValue err -> return (L.Error err, Nothing)
|
||||
|
||||
-- the expressions built here can be quite large,
|
||||
-- but will be reduced during optimisation if possible
|
||||
C.ParamConstant (C.Param pid lvs) -> do
|
||||
let
|
||||
collectProjections :: C.LinValue -> Either String [L.LinFun]
|
||||
collectProjections (C.ParamConstant (C.Param pid lvs)) = do
|
||||
def <- [ d | d@(C.ParamDef _ ps) <- params, any (\(C.Param p _) -> p == pid) ps ]
|
||||
`headOrLeft` printf "Cannot find param group: %s" (show pid)
|
||||
def <- m2e (printf "Cannot find param definition: %s" (show pid)) (Map.lookup pid paramValueMap)
|
||||
let (C.ParamDef tpid defpids) = def
|
||||
pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
|
||||
rest <- mapM collectProjections lvs
|
||||
@@ -117,38 +130,31 @@ mkCanon2lpgf opts gr am = do
|
||||
collectProjections lv = do
|
||||
(lf,_) <- val2lin lv
|
||||
return [lf]
|
||||
|
||||
-- get param group index and defn for this constructor
|
||||
(gix,def) <- [ (gix,d) | (gix,d@(C.ParamDef _ ps)) <- zip [0..] params, any (\(C.Param p _) -> p == pid) ps ]
|
||||
`headOrLeft` printf "Cannot find param group: %s" (show pid)
|
||||
let (C.ParamDef tpid _) = def
|
||||
|
||||
-- let tuple = paramTuples !! gix
|
||||
lfs <- collectProjections lv
|
||||
-- let term = foldl L.Projection tuple lfs
|
||||
let term = L.Tuple lfs -- unapplied!
|
||||
|
||||
let term = L.Tuple lfs
|
||||
def <- m2e (printf "Cannot find param definition: %s" (show pid)) (Map.lookup pid paramValueMap)
|
||||
let (C.ParamDef tpid _) = def
|
||||
return (term, Just $ C.ParamType (C.ParamTypeId tpid))
|
||||
|
||||
C.Selection v1 v2 -> do
|
||||
(v1', t1) <- val2lin v1
|
||||
(v2', t2) <- val2lin v2
|
||||
-- let Just (C.TableType t11 t12) = t1 -- t11 == t2
|
||||
|
||||
case t1 of
|
||||
Just (C.TableType (C.ParamType (C.ParamTypeId pid)) tret) -> do
|
||||
(gix,_) <- [ (gix,d) | (gix,d@(C.ParamDef p _)) <- zip [0..] params, p == pid ]
|
||||
`headOrLeft` printf "Cannot find param group: %s" (show pid)
|
||||
let tuple = paramTuples !! gix
|
||||
let v2'' = case v2' of
|
||||
L.Tuple lfs -> foldl L.Projection tuple lfs
|
||||
lf -> L.Projection tuple lf
|
||||
return (L.Projection v1' v2'', Just tret)
|
||||
|
||||
Just (C.TableType (C.RecordType rrts) tret) ->
|
||||
return (L.Projection v1' v2', Just tret)
|
||||
|
||||
_ -> Left $ printf "Unhandled type in selection: %s" (show t1)
|
||||
-- C.Selection v1 v2 -> do
|
||||
-- (v1', t1) <- val2lin v1
|
||||
-- (v2', t2) <- val2lin v2
|
||||
-- -- let Just (C.TableType t11 t12) = t1 -- t11 == t2
|
||||
--
|
||||
-- case t1 of
|
||||
-- Just (C.TableType (C.ParamType (C.ParamTypeId pid)) tret) -> do
|
||||
-- (gix,_) <- [ (gix,d) | (gix,d@(C.ParamDef p _)) <- zip [0..] params, p == pid ]
|
||||
-- `headOrLeft` printf "Cannot find param group: %s" (show pid)
|
||||
-- let tuple = paramTuples !! gix
|
||||
-- let v2'' = case v2' of
|
||||
-- L.Tuple lfs -> foldl L.Projection tuple lfs
|
||||
-- lf -> L.Projection tuple lf
|
||||
-- return (L.Projection v1' v2'', Just tret)
|
||||
--
|
||||
-- Just (C.TableType (C.RecordType rrts) tret) ->
|
||||
-- return (L.Projection v1' v2', Just tret)
|
||||
--
|
||||
-- _ -> Left $ printf "Unhandled type in selection: %s" (show t1)
|
||||
|
||||
C.PredefValue (C.PredefId pid) -> case pid of
|
||||
"BIND" -> return (L.Bind, Nothing)
|
||||
@@ -217,11 +223,11 @@ mkCanon2lpgf opts gr am = do
|
||||
let C.RecordRow _ lt = rrs !! lblIx
|
||||
return (L.Projection v1' (L.Ix (lblIx+1)), Just lt)
|
||||
|
||||
-- C.Selection v1 v2 -> do
|
||||
-- (v1', t1) <- val2lin v1
|
||||
-- (v2', t2) <- val2lin v2
|
||||
-- let Just (C.TableType t11 t12) = t1
|
||||
-- return (L.Projection v1' v2', Just t12)
|
||||
C.Selection v1 v2 -> do
|
||||
(v1', t1) <- val2lin v1
|
||||
(v2', t2) <- val2lin v2
|
||||
let Just (C.TableType t11 t12) = t1 -- t11 == t2
|
||||
return (L.Projection v1' v2', Just t12)
|
||||
|
||||
C.CommentedValue cmnt lv -> val2lin lv
|
||||
|
||||
@@ -357,10 +363,10 @@ reduce lf = case lf of
|
||||
(t',u') -> L.Projection t' u'
|
||||
t -> t
|
||||
|
||||
-- | If list is non-empty return its head, else a fallback value
|
||||
headOrLeft :: [a] -> b -> Either b a
|
||||
headOrLeft (a:_) _ = Right a
|
||||
headOrLeft _ b = Left b
|
||||
-- -- | If list is non-empty return its head, else a fallback value
|
||||
-- headOrLeft :: [a] -> b -> Either b a
|
||||
-- headOrLeft (a:_) _ = Right a
|
||||
-- headOrLeft _ b = Left b
|
||||
|
||||
-- | Convert Maybe to Either value with error
|
||||
m2e :: String -> Maybe a -> Either String a
|
||||
|
||||
@@ -102,9 +102,9 @@ data TableRow rhs = TableRow LinPattern rhs
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
|
||||
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
|
||||
data VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
|
||||
newtype PredefId = PredefId Id deriving (Eq,Ord,Show)
|
||||
newtype LabelId = LabelId Id deriving (Eq,Ord,Show)
|
||||
newtype VarValueId = VarValueId QualId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Name of param type or param value
|
||||
newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
|
||||
@@ -115,7 +115,7 @@ newtype ParamId = ParamId QualId deriving (Eq,Ord,Show)
|
||||
newtype ModId = ModId 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,Ord,Show)
|
||||
|
||||
data VarId = Anonymous | VarId Id deriving (Eq,Show)
|
||||
|
||||
|
||||
@@ -47,3 +47,108 @@ stack bench --benchmark-arguments "run pgf Foods.pgf testsuite/lpgf/foods/Food
|
||||
stack bench --benchmark-arguments "run pgf2 Foods.pgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
|
||||
stack bench --benchmark-arguments "run lpgf Foods.lpgf testsuite/lpgf/foods/Foods-all.trees +RTS -T -RTS"
|
||||
```
|
||||
|
||||
|
||||
# Notes on compilation
|
||||
|
||||
## 1
|
||||
|
||||
param defns
|
||||
P = P1 | P2
|
||||
Q = Q1 | Q2
|
||||
R = RP P | RPQ P Q | R0
|
||||
X = XPQ P Q
|
||||
|
||||
translation (NB: tuples may be listed, but will be concatted at runtime)
|
||||
|
||||
P1 = <1>
|
||||
P2 = <2>
|
||||
|
||||
Q1 = <1>
|
||||
Q2 = <2>
|
||||
|
||||
R P1 = <1,1>
|
||||
R P2 = <1,2>
|
||||
RPQ P1 Q1 = <2,1,1>
|
||||
RPQ P1 Q2 = <2,1,2>
|
||||
RPQ P2 Q1 = <2,2,1>
|
||||
RPQ P2 Q2 = <2,2,2>
|
||||
R0 = <3>
|
||||
|
||||
XPQ P1 Q1 = <1,1,1>
|
||||
XPQ P1 Q2 = <1,1,2>
|
||||
XPQ P2 Q1 = <1,2,1>
|
||||
XPQ P2 Q2 = <1,2,2>
|
||||
|
||||
P => Str
|
||||
<"P1","P2">
|
||||
|
||||
{p:P ; q:Q} => Str
|
||||
<<"P1;Q1","P1;Q2">,<"P2;Q1","P2;Q2">>
|
||||
|
||||
{p=P2; q=Q1}
|
||||
<<2>,<1>>
|
||||
|
||||
R => Str
|
||||
< <"RP P1","RP P2">,
|
||||
< <"RPQ P1 Q1","RPQ P1 Q2">,
|
||||
<"RPQ P2 Q1","RPQ P2 Q2"> >,
|
||||
"R0"
|
||||
>
|
||||
|
||||
X => Str
|
||||
<<<"XPQ P1 Q1","XPQ P1 Q2">,
|
||||
<"XPQ P2 Q1","XPQ P2 Q2">>>
|
||||
|
||||
{p=P2 ; r=R0}
|
||||
<<2>,<3>>
|
||||
|
||||
{p=P2 ; r1=RP P1 ; r2=RPQ P1 Q2 ; r3=R0 }
|
||||
< <2> , <1, 1> , <2, 1, 2> , <3>>
|
||||
|
||||
## 2
|
||||
|
||||
param defns
|
||||
P = P1 | PQ Q
|
||||
Q = Q1 | QR R
|
||||
R = R1 | R2
|
||||
|
||||
translation
|
||||
|
||||
P1 = <1>
|
||||
PQ Q1 = <2,1>
|
||||
PQ QR R1 = <2,2,1>
|
||||
PQ QR R2 = <2,2,2>
|
||||
|
||||
Q1 = <1>
|
||||
QR R1 = <2,1>
|
||||
QR R2 = <2,2>
|
||||
|
||||
R1 = <1>
|
||||
R2 = <2>
|
||||
|
||||
P => Str
|
||||
<"P1",<"PQ Q1",<"PQ (QR R1)","PQ (QR R2)">>>
|
||||
|
||||
{q:Q ; p:P} => Str
|
||||
< <"Q1;P1",<"Q1;PQ Q1",<"Q1;PQ (QR R1)","Q1;PQ (QR R2)">>>,
|
||||
<
|
||||
<"QR R1;P1",<"QR R1;PQ Q1",<"QR R1;PQ (QR R1)","QR R1;PQ (QR R2)">>>,
|
||||
<"QR R2;P1",<"QR R2;PQ Q1",<"QR R2;PQ (QR R1)","QR R2;PQ (QR R2)">>>
|
||||
>
|
||||
>
|
||||
|
||||
{q=Q1 ; p=P1} = <<1>,<1>>
|
||||
{q=Q1 ; p=PQ Q1} = <<1>,<2,1>>
|
||||
{q=Q1 ; p=PQ (QR R1)} = <<1>,<2,2,1>>
|
||||
{q=Q1 ; p=PQ (QR R2)} = <<1>,<2,2,2>>
|
||||
|
||||
{q=QR R1 ; p=P1} = <<2,1>,<1>>
|
||||
{q=QR R1 ; p=PQ Q1} = <<2,1>,<2,1>>
|
||||
{q=QR R1 ; p=PQ (QR R1)} = <<2,1>,<2,2,1>>
|
||||
{q=QR R1 ; p=PQ (QR R2)} = <<2,1>,<2,2,2>>
|
||||
|
||||
{q=QR R2 ; p=P1} = <<2,2>,<1>>
|
||||
{q=QR R2 ; p=PQ Q1} = <<2,2>,<2,1>>
|
||||
{q=QR R2 ; p=PQ (QR R1)} = <<2,2>,<2,2,1>>
|
||||
{q=QR R2 ; p=PQ (QR R2)} = <<2,2>,<2,2,2>>
|
||||
|
||||
@@ -38,34 +38,34 @@ walking = LPGF {
|
||||
concretes = Map.fromList [
|
||||
(mkCId "WalkingEng", Concr {
|
||||
-- lincats = Map.fromList [
|
||||
-- (mkCId "S", LTStr),
|
||||
-- (mkCId "NP", LTProduct [LTStr, LTInt 2]),
|
||||
-- (mkCId "VP", LTProduct [LTStr, LTStr])
|
||||
-- (mkCId "S", StrType),
|
||||
-- (mkCId "NP", ProductType [StrType, IxType 2]),
|
||||
-- (mkCId "VP", ProductType [StrType, StrType])
|
||||
-- ],
|
||||
lins = Map.fromList [
|
||||
(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 (LFProjection (LFArgument 2) (LFInt 1)) (LFProjection (LFArgument 1) (LFInt 2))]),
|
||||
(mkCId "John", LFTuple [LFToken "John", LFInt 1]),
|
||||
(mkCId "We", LFTuple [LFToken "we", LFInt 2]),
|
||||
-- (mkCId "Walk", LFTuple [LFToken "walks", LFToken "walk"])
|
||||
(mkCId "Walk", LFTuple [LFTuple [LFToken "walks", LFToken "walk"]])
|
||||
(mkCId "And", mkConcat [Argument 1, Token "and", Argument 2]),
|
||||
-- (mkCId "Pred", mkConcat [Projection (Argument 1) (Ix 1), Projection (Argument 2) (Projection (Argument 1) (Ix 2))]),
|
||||
(mkCId "Pred", mkConcat [Projection (Argument 1) (Ix 1), Projection (Projection (Argument 2) (Ix 1)) (Projection (Argument 1) (Ix 2))]),
|
||||
(mkCId "John", Tuple [Token "John", Ix 1]),
|
||||
(mkCId "We", Tuple [Token "we", Ix 2]),
|
||||
-- (mkCId "Walk", Tuple [Token "walks", Token "walk"])
|
||||
(mkCId "Walk", Tuple [Tuple [Token "walks", Token "walk"]])
|
||||
]
|
||||
}),
|
||||
(mkCId "WalkingGer", Concr {
|
||||
-- lincats = Map.fromList [
|
||||
-- (mkCId "S", LTStr),
|
||||
-- (mkCId "NP", LTProduct [LTStr, LTInt 2, LTInt 3]),
|
||||
-- (mkCId "VP", LTProduct [LTProduct [LTStr, LTStr, LTStr], LTProduct [LTStr, LTStr, LTStr]])
|
||||
-- (mkCId "S", StrType),
|
||||
-- (mkCId "NP", ProductType [StrType, IxType 2, IxType 3]),
|
||||
-- (mkCId "VP", ProductType [ProductType [StrType, StrType, StrType], ProductType [StrType, StrType, StrType]])
|
||||
-- ],
|
||||
lins = Map.fromList [
|
||||
(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 (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 "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 [LFTuple [LFToken "gehe", LFToken "gehst", LFToken "geht"], LFTuple [LFToken "gehen", LFToken "geht", LFToken "gehen"]]])
|
||||
(mkCId "And", mkConcat [Argument 1, Token "und", Argument 2]),
|
||||
-- (mkCId "Pred", mkConcat [Projection (Argument 1) (Ix 1), Projection (Projection (Argument 2) (Projection (Argument 1) (Ix 2))) (Projection (Argument 1) (Ix 3))]),
|
||||
(mkCId "Pred", mkConcat [Projection (Argument 1) (Ix 1), Projection (Projection (Projection (Argument 2) (Ix 1)) (Projection (Argument 1) (Ix 2))) (Projection (Argument 1) (Ix 3))]),
|
||||
(mkCId "John", Tuple [Token "John", Ix 1, Ix 3]),
|
||||
(mkCId "We", Tuple [Token "wir", Ix 2, Ix 1]),
|
||||
-- (mkCId "Walk", Tuple [Tuple [Token "gehe", Token "gehst", Token "geht"], Tuple [Token "gehen", Token "geht", Token "gehen"]])
|
||||
(mkCId "Walk", Tuple [Tuple [Tuple [Token "gehe", Token "gehst", Token "geht"], Tuple [Token "gehen", Token "geht", Token "gehen"]]])
|
||||
]
|
||||
})
|
||||
]
|
||||
@@ -73,6 +73,6 @@ walking = LPGF {
|
||||
|
||||
-- | Helper for building concat trees
|
||||
mkConcat :: [LinFun] -> LinFun
|
||||
mkConcat [] = LFEmpty
|
||||
mkConcat [] = Empty
|
||||
mkConcat [x] = x
|
||||
mkConcat xs = foldl1 LFConcat xs
|
||||
mkConcat xs = foldl1 Concat xs
|
||||
|
||||
Reference in New Issue
Block a user