diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 33f35ad08..f43e0c863 100644 --- 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)) diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 6976168b8..54b449dfe 100644 --- 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 diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 4adff02f2..ca549c8c7 100644 --- 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 "=" diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index fd4003698..9c21b1173 100644 --- 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 diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index f07ee7ecc..68b01187f 100644 --- 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"]]]) ] }) ]