diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index e6f7a9d34..7edc0fc4f 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -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 diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index ca549c8c7..6b39e4b00 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -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) diff --git a/testsuite/lpgf/README.md b/testsuite/lpgf/README.md index 8a50c7d3e..52aac25fb 100644 --- a/testsuite/lpgf/README.md +++ b/testsuite/lpgf/README.md @@ -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>> diff --git a/testsuite/lpgf/walking/Walking.hs b/testsuite/lpgf/walking/Walking.hs index d8b1da0e9..fc30fb41f 100644 --- a/testsuite/lpgf/walking/Walking.hs +++ b/testsuite/lpgf/walking/Walking.hs @@ -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