Use canonical GF in LPGF compiler

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.
2026-04-09 04:59:31 -06:00 · 2021-02-01 12:28:06 +01:00
parent cead0cc4c1
commit fe15aa0c00
5 changed files with 137 additions and 111 deletions
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -17,7 +17,7 @@ import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
 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 GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
 import GF.Grammar.Canonical as C
@@ -25,6 +25,7 @@ import Debug.Trace

 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> SourceGrammar -> C.Grammar
 grammar2canonical opts absname gr =
   Grammar (abstract2canonical absname gr)
           (map snd (concretes2canonical opts absname gr))
@@ -72,7 +73,7 @@ concrete2canonical gr cenv absname cnc modinfo =
      [lincat|(_,Left lincat)<-defs]
      [lin|(_,Right lin)<-defs]
  where
-    defs = concatMap (toCanonical gr absname cenv) . 
+    defs = concatMap (toCanonical gr absname cenv) .
           M.toList $
           jments modinfo

@@ -189,7 +190,7 @@ convert' gr vs = ppT
        _ -> VarValue (gQId cPredef n) -- hmm
      where
       p = PredefValue . PredefId
-      
+
    ppP p =
      case p of
        PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
--- a/src/compiler/GF/Compile/GrammarToLPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToLPGF.hs
@@ -4,134 +4,146 @@ import LPGF (LPGF (..))
 import qualified LPGF as L

 import PGF.CId
-import GF.Grammar.Predef
+-- import GF.Grammar.Predef
 import GF.Grammar.Grammar
-import qualified GF.Grammar.Lookup as Look
-import qualified GF.Grammar as A
-import qualified GF.Grammar.Macros as GM
+-- import qualified GF.Grammar.Lookup as Look
+-- import qualified GF.Grammar as A
+-- 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.Option
 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 qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (catMaybes)
+import Text.Printf (printf)

 mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
 mkCanon2lpgf opts gr am = do
-  (an,abs) <- mkAbstr am
-  cncs     <- mapM mkConcr (allConcretes gr am)
-  return $ LPGF {
+  let grcn@(C.Grammar ab cncs) = grammar2canonical opts am gr
+  (an,abs) <- mkAbstr ab
+  cncs     <- mapM mkConcr cncs
+  let lpgf = LPGF {
    L.absname = an,
    L.abstract = abs,
    L.concretes = Map.fromList cncs
  }
+  print lpgf
+  return lpgf
  where
-    mkAbstr :: ModuleName -> IOE (CId, L.Abstr)
-    mkAbstr am = do
-      let
-        adefs =
-            [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++
-            Look.allOrigInfos gr am
+    mkAbstr :: C.Abstract -> IOE (CId, L.Abstr)
+    mkAbstr (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstr {})

-        -- funs = Map.fromList [ (i2i f, mkType [] ty)
-        --                     | ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs
-        --                     , let arity = mkArity ma mdef ty
-        --                     ]
-        --
-        -- cats = Map.fromList [ (i2i c, ())
-        --                     | ((m,c),AbsCat (Just (L _ cont))) <- adefs
-        --                     ]
-
-      return (mi2i am, L.Abstr {
-        -- L.cats = cats,
-        -- L.funs = funs
-      })
-
-    mkConcr :: ModuleName -> IOE (CId, L.Concr)
-    mkConcr cm = do
+    mkConcr :: C.Concrete -> IOE (CId, L.Concr)
+    mkConcr (C.Concrete modId absModId flags params lincats lindefs) = do
+      -- print modId
+      -- print absModId
+      -- print flags
+      -- print params
+      -- print lincats
+      -- print lindefs

      let
-        js = fromErr [] $ do
-          mo <- lookupModule gr cm
-          -- return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [Look.lookupOrigInfo gr (cm,c)]]
-          return $ Map.toList (jments mo)
+        es = map mkLin lindefs
+        lins = Map.fromList $ rights es

-        -- lincats = Map.fromList []
-        lins = Map.fromList $ mapMaybe mkLin js
+        mkLin :: C.LinDef -> Either String (CId, L.LinFun)
+        mkLin ld@(C.LinDef funId varIds linValue) = do
+          lf <- val2lin varIds linValue
+          return (fi2i funId, lf)

-        mkLin :: (Ident, Info) -> Maybe (CId, L.LinFun)
-        mkLin (i, info) = case info of
-          CncFun typ def@(Just (L (Local n _) term)) pn pmcfg -> do
-            lin <- term2lin [] Nothing term
-            return (i2i i, lin)
-          _ -> Nothing
+        val2lin :: [C.VarId] -> C.LinValue -> Either String L.LinFun
+        val2lin vids lv = case lv of

-        term2lin :: [Ident] -> Maybe Type -> Term -> Maybe L.LinFun
-        term2lin cxt mtype t = case t of
-          -- abstraction: x -> b
-          Abs Explicit arg term -> term2lin (arg:cxt) mtype term
+          C.ConcatValue v1 v2 -> do
+            v1' <- val2lin vids v1
+            v2' <- val2lin vids v2
+            return $ L.LFConcat v1' v2'

-          -- concatenation: s ++ t
-          C t1 t2 -> do
-            t1' <- term2lin cxt Nothing t1
-            t2' <- term2lin cxt Nothing t2
-            return $ L.LFConcat t1' t2'
+          C.LiteralValue ll -> case ll of
+            C.FloatConstant f -> return $ L.LFToken (show f)
+            C.IntConstant i -> return $ L.LFToken (show i) -- LFInt ?
+            C.StrConstant s -> return $ L.LFToken s

-          -- string literal or token: "foo"
-          K s -> Just $ L.LFToken s
+          C.ErrorValue err -> return $ L.LFError err

-          -- variable
-          Vr arg -> do
-            ix <- elemIndex arg (reverse cxt)
-            return $ L.LFArgument (ix+1)
+          C.ParamConstant p@(C.Param (C.ParamId (C.Qual _ _)) _) -> do
+            let
+              mixs =
+                [ 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 ; ... }
-          R asgns -> do
-            ts <- sequence [ term2lin cxt mtype term | (_, (mtype, term)) <- asgns ]
+          -- PredefValue PredefId -- TODO predef not supported
+
+          C.RecordValue rrvs -> do
+            ts <- sequence [ val2lin vids lv | C.RecordRow lid lv <- rrvs ]
            return $ L.LFTuple ts

-          -- qualified constructor from a package
-          QC qiV -> do
-            QC qiP <- mtype
-            let vs = [ ic | QC ic <- fromErr [] $ Look.lookupParamValues gr qiP ]
-            ix <- elemIndex qiV vs
-            return $ L.LFInt (ix+1)
+          C.TableValue lt trvs -> do
+            ts <- sequence [ val2lin vids lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs
+            return $ L.LFTuple ts

-          -- projection: r.p
-          P term lbl -> do
-            t <- term2lin cxt mtype term
-            let ix = 0 -- TODO need type of t to lookup this
-            return $ L.LFProjection t (L.LFInt (ix+1))
+          C.TupleValue lvs -> do
+            ts <- mapM (val2lin vids) lvs
+            return $ L.LFTuple ts

-          -- selection: t ! p
-          S t1 t2 -> do -- TODO
-            t1' <- term2lin cxt mtype t1
-            t2' <- term2lin cxt mtype t2
-            return $ L.LFProjection t1' t2'
+          C.VariantValue [] -> return L.LFEmpty
+          C.VariantValue (vr:_) -> val2lin vids vr -- TODO variants not supported, just pick first

-          _ -> 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.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 = utf8CId . ident2utf8

 mi2i :: ModuleName -> CId
 mi2i (MN i) = i2i i

-- mkType :: [Ident] -> A.Type -> L.Type
-- mkType scope t =
--   case GM.typeForm t of
--     (hyps,(_,cat),args) -> L.Type (map (\(bt,i,t) -> i2i i) hyps) (i2i cat)
+mdi2i :: C.ModId -> CId
+mdi2i (C.ModId i) = mkCId i

-- mkArity (Just a) _        ty = a   -- known arity, i.e. defined function
-- mkArity Nothing  (Just _) ty = 0   -- defined function with no arity - must be an axiom
-- mkArity Nothing  _        ty = let (ctxt, _, _) = GM.typeForm ty  -- constructor
--                                in length ctxt
+fi2i :: C.FunId -> CId
+fi2i (C.FunId i) = mkCId i
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -30,7 +30,7 @@ data TypeApp  = TypeApp CatId [Type]        deriving Show
 data TypeBinding = TypeBinding VarId Type   deriving Show

 --------------------------------------------------------------------------------
-- ** Concreate syntax
+-- ** Concrete syntax

 -- | Concrete Syntax
 data Concrete  = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
@@ -44,12 +44,12 @@ data LincatDef = LincatDef CatId LinType  deriving Show
 data LinDef    = LinDef FunId [VarId] LinValue  deriving Show

 -- | Linearization type, RHS of @lincat@
-data LinType = FloatType 
-             | IntType 
+data LinType = FloatType
+             | IntType
             | ParamType ParamType
             | RecordType [RecordRowType]
-             | StrType 
-             | TableType LinType LinType 
+             | StrType
+             | TableType LinType LinType
             | TupleType [LinType]
              deriving (Eq,Ord,Show)

@@ -59,7 +59,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 data LinValue = ConcatValue LinValue LinValue
              | LiteralValue LinLiteral
              | ErrorValue String
-              | ParamConstant ParamValue 
+              | ParamConstant ParamValue
              | PredefValue PredefId
              | RecordValue [RecordRowValue]
              | TableValue LinType [TableRowValue]
@@ -73,9 +73,9 @@ data LinValue = ConcatValue LinValue LinValue
              | CommentedValue String LinValue
              deriving (Eq,Ord,Show)

-data LinLiteral = FloatConstant Float 
-                | IntConstant Int 
-                | StrConstant String 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
                deriving (Eq,Ord,Show)

 data LinPattern = ParamPattern ParamPattern
@@ -106,7 +106,7 @@ newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
 newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
 data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)

-- | Name of param type or param value 
+-- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)

 --------------------------------------------------------------------------------
@@ -117,7 +117,7 @@ newtype ModId = ModId Id  deriving (Eq,Ord,Show)
 newtype CatId = CatId Id  deriving (Eq,Ord,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
 type FlagName = Id
@@ -249,7 +249,7 @@ instance PPA LinLiteral where
            FloatConstant f -> pp f
            IntConstant n -> pp n
            StrConstant s -> doubleQuotes s -- hmm
-  
+
 instance RhsSeparator LinValue where rhsSep _ = pp "="

 instance Pretty LinPattern where
@@ -264,7 +264,7 @@ instance PPA LinPattern where
      ParamPattern pv -> ppA pv
      RecordPattern r -> block r
      TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
+      WildPattern     -> pp "_"
      _ -> parens p

 instance RhsSeparator LinPattern where rhsSep _ = pp "="
--- a/src/runtime/haskell/LPGF.hs
+++ b/src/runtime/haskell/LPGF.hs
@@ -44,7 +44,8 @@ data LinType =

 -- | Linearisation function
 data LinFun =
-    LFEmpty
+    LFError String
+  | LFEmpty
  | LFToken String
  | LFConcat LinFun LinFun
  | LFInt Int
@@ -125,6 +126,7 @@ type Context = [LinFun]
 -- | Operational semantics, Table 2
 eval :: Context -> LinFun -> LinFun
 eval cxt t = case t of
+  LFError err -> error err
  LFEmpty -> LFEmpty
  LFToken tok -> LFToken tok
  LFConcat s t -> LFConcat v w
@@ -136,8 +138,14 @@ eval cxt t = case t of
    where vs = map (eval cxt) ts
  LFProjection t u -> vs !! (i-1)
    where
-      LFTuple vs = eval cxt t
-      LFInt i = eval cxt u
+      -- LFTuple vs = eval cxt t
+      -- 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)

 -- | Turn concrete syntax terms into an actual string
--- a/testsuite/lpgf/run.hs
+++ b/testsuite/lpgf/run.hs
@@ -18,6 +18,7 @@ main = do

  -- Do some linearization
  forM_ [tree1, tree2, tree3] $ \tree -> do
+    putStrLn ""
    putStrLn (showExpr [] tree)
    forM_ (Map.toList (concretes lpgf)) $ \(lang,concr) ->
      printf "%s: %s\n" (showLanguage lang) (linearizeConcr concr tree)
@@ -61,10 +62,12 @@ walking = LPGF {
      -- ],
      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 (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 [LFToken "walks", LFToken "walk"])
+        (mkCId "Walk", LFTuple [LFTuple [LFToken "walks", LFToken "walk"]])
      ]
    }),
    (mkCId "WalkingGer", Concr {
@@ -75,10 +78,12 @@ walking = LPGF {
      -- ],
      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 (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 [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"]]])
      ]
    })
  ]