diff --git a/gf.cabal b/gf.cabal index fb4acef69..f350b2ca1 100644 --- a/gf.cabal +++ b/gf.cabal @@ -151,6 +151,7 @@ Library GF.Support GF.Text.Pretty GF.Text.Lexing + GF.Grammar.Canonical other-modules: GF.Main GF.Compiler GF.Interactive @@ -190,7 +191,6 @@ Library GF.Haskell GF.Compile.ConcreteToHaskell GF.Compile.GrammarToCanonical - GF.Grammar.Canonical GF.Grammar.CanonicalJSON GF.Compile.PGFtoJS GF.Compile.PGFtoProlog diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs index 8938a053e..a99970a57 100644 --- a/src/compiler/GF.hs +++ b/src/compiler/GF.hs @@ -19,7 +19,9 @@ module GF( module GF.Grammar.Printer, module GF.Infra.Ident, -- ** Binary serialisation - module GF.Grammar.Binary + module GF.Grammar.Binary, + -- * Canonical GF + module GF.Compile.GrammarToCanonical ) where import GF.Main import GF.Compiler @@ -36,3 +38,5 @@ import GF.Grammar.Macros import GF.Grammar.Printer import GF.Infra.Ident import GF.Grammar.Binary + +import GF.Compile.GrammarToCanonical diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index 804db9d50..6d2bf398f 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -142,8 +142,8 @@ concrete2haskell opts rhs = lets (zipWith letlin args absctx) (convert vs (coerce env lincat rhs0)) where - vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args] - env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] + vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args] + env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)] letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) = (a,Ap (Var (linfunName acat)) (Var (abs_arg a))) @@ -173,15 +173,20 @@ concrete2haskell opts VariantValue [] -> empty VariantValue ts@(_:_) -> variants ts VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs - IntConstant n -> pure (lit n) - StrConstant s -> pure (token s) PreValue vs t' -> pure (alts t' vs) ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs) ErrorValue s -> ap (Const "error") (Const (show s)) -- !! + LiteralValue l -> ppL l _ -> error ("convert "++show t) + ppL l = + case l of + FloatConstant x -> pure (lit x) + IntConstant n -> pure (lit n) + StrConstant s -> pure (token s) + pId p@(ParamId s) = - if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack + if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack table cs = if all (null.patVars) ps @@ -329,7 +334,7 @@ coerce env ty t = _ -> t where app f ts = ParamConstant (Param f ts) -- !! a hack - to_rcon = ParamId . to_rcon' . labels + to_rcon = ParamId . Unqual . to_rcon' . labels patVars p = [] @@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c) class ToIdent i where toIdent :: i -> Ident -instance ToIdent ParamId where toIdent (ParamId s) = identS s +instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q instance ToIdent PredefId where toIdent (PredefId s) = identS s instance ToIdent CatId where toIdent (CatId s) = identS s instance ToIdent C.FunId where toIdent (FunId s) = identS s -instance ToIdent VarValueId where toIdent (VarValueId s) = identS s +instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q + +qIdentS = identS . unqual + +unqual (Qual (ModId m) n) = m++"_"++n +unqual (Unqual n) = n instance ToIdent VarId where toIdent Anonymous = identW diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs index 4bd9130b2..7442bd495 100644 --- a/src/compiler/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/GF/Compile/GrammarToCanonical.hs @@ -165,11 +165,11 @@ convert' gr vs = ppT Cn x -> VarValue (gId x) -- hmm Con c -> ParamConstant (Param (gId c) []) Sort k -> VarValue (gId k) - EInt n -> IntConstant n - Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) - QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) - K s -> StrConstant s - Empty -> StrConstant "" + EInt n -> LiteralValue (IntConstant n) + Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n)) + QC (m,n) -> ParamConstant (Param ((gQId m n)) []) + K s -> LiteralValue (StrConstant s) + Empty -> LiteralValue (StrConstant "") FV ts -> VariantValue (map ppT ts) Alts t' vs -> alts vs (ppT t') _ -> error $ "convert' "++show t @@ -183,14 +183,14 @@ convert' gr vs = ppT Ok SOFT_SPACE -> p "SOFT_SPACE" Ok CAPIT -> p "CAPIT" Ok ALL_CAPIT -> p "ALL_CAPIT" - _ -> VarValue (gId n) + _ -> VarValue (gQId cPredef n) -- hmm where p = PredefValue . PredefId ppP p = case p of PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) - PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps)) PR r -> RecordPattern (fields r) {- PW -> WildPattern PV x -> VarP x @@ -233,8 +233,8 @@ convert' gr vs = ppT concatValue v1 v2 = case (v1,v2) of - (StrConstant "",_) -> v2 - (_,StrConstant "") -> v1 + (LiteralValue (StrConstant ""),_) -> v2 + (_,LiteralValue (StrConstant "")) -> v1 _ -> ConcatValue v1 v2 projection r l = maybe (Projection r l) id (proj r l) @@ -298,8 +298,8 @@ convType = ppT Sort k -> convSort k -- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal FV (t:ts) -> ppT t -- !! - QC (m,n) -> ParamType (ParamTypeId (gId (qual m n))) - Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + QC (m,n) -> ParamType (ParamTypeId ((gQId m n))) + Q (m,n) -> ParamType (ParamTypeId ((gQId m n))) _ -> error $ "Missing case in convType for: "++show t convFields = map convField . filter (not.isLockLabel.fst) @@ -325,25 +325,21 @@ paramType gr q@(_,n) = ((S.singleton (m,n),argTypes ps), [ParamDef name (map (param m) ps)] ) - where name = gId (qual m n) + where name = (gQId m n) Ok (m,ResOper _ (Just (L _ t))) | m==cPredef && n==cInts -> ((S.empty,S.empty),[]) {- ((S.singleton (m,n),S.empty), - [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} + [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-} | otherwise -> ((S.singleton (m,n),paramTypes gr t), - [ParamAliasDef (gId (qual m n)) (convType t)]) + [ParamAliasDef ((gQId m n)) (convType t)]) _ -> ((S.empty,S.empty),[]) where - param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] + param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx] argTypes = S.unions . map argTypes1 argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] -qual :: ModuleName -> Ident -> Ident -qual m = prefixIdent (render m++"_") - - lblId = LabelId . render -- hmm modId (MN m) = ModId (showIdent m) @@ -354,8 +350,16 @@ instance FromIdent VarId where instance FromIdent C.FunId where gId = C.FunId . showIdent instance FromIdent CatId where gId = CatId . showIdent -instance FromIdent ParamId where gId = ParamId . showIdent -instance FromIdent VarValueId where gId = VarValueId . showIdent +instance FromIdent ParamId where gId = ParamId . unqual +instance FromIdent VarValueId where gId = VarValueId . unqual + +class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i + +instance QualIdent ParamId where gQId m n = ParamId (qual m n) +instance QualIdent VarValueId where gQId m n = VarValueId (qual m n) + +qual m n = Qual (modId m) (showIdent n) +unqual n = Unqual (showIdent n) convFlags gr mn = Flags [(n,convLit v) | diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 0da72d634..ab9bf280c 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -1,7 +1,12 @@ --- | Abstract syntax for canonical GF grammars, i.e. what's left after +-- | +-- Module : GF.Grammar.Canonical +-- Stability : provisional +-- +-- Abstract syntax for canonical GF grammars, i.e. what's left after -- high-level constructions such as functors and opers have been eliminated -- by partial evaluation. This is intended as a common intermediate -- representation to simplify export to other formats. + module GF.Grammar.Canonical where import Prelude hiding ((<>)) import GF.Text.Pretty @@ -51,13 +56,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show) -- | Linearization value, RHS of @lin@ data LinValue = ConcatValue LinValue LinValue + | LiteralValue LinLiteral | ErrorValue String - | FloatConstant Float - | IntConstant Int | ParamConstant ParamValue | PredefValue PredefId | RecordValue [RecordRowValue] - | StrConstant String | TableValue LinType [TableRowValue] --- | VTableValue LinType [LinValue] | TupleValue [LinValue] @@ -66,7 +69,12 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show) + +data LinLiteral = FloatConstant Float + | IntConstant Int + | StrConstant String + deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] @@ -87,27 +95,33 @@ data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) -- *** Identifiers in Concrete Syntax -newtype PredefId = PredefId String deriving (Eq,Ord,Show) -newtype LabelId = LabelId String deriving (Eq,Ord,Show) -data VarValueId = VarValueId String deriving (Eq,Ord,Show) +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 -newtype ParamId = ParamId String deriving (Eq,Ord,Show) +newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- -- ** Used in both Abstract and Concrete Syntax -newtype ModId = ModId String deriving (Eq,Show) +newtype ModId = ModId Id deriving (Eq,Ord,Show) -newtype CatId = CatId String deriving (Eq,Ord,Show) -newtype FunId = FunId String deriving (Eq,Show) +newtype CatId = CatId Id deriving (Eq,Ord,Show) +newtype FunId = FunId Id deriving (Eq,Show) -data VarId = Anonymous | VarId String deriving Show +data VarId = Anonymous | VarId Id deriving Show newtype Flags = Flags [(FlagName,FlagValue)] deriving Show -type FlagName = String +type FlagName = Id data FlagValue = Str String | Int Int | Flt Double deriving Show + +-- *** Identifiers + +type Id = String +data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show) + -------------------------------------------------------------------------------- -- ** Pretty printing @@ -203,8 +217,7 @@ instance Pretty LinValue where instance PPA LinValue where ppA lv = case lv of - FloatConstant f -> pp f - IntConstant n -> pp n + LiteralValue l -> ppA l ParamConstant pv -> ppA pv PredefValue p -> ppA p RecordValue [] -> pp "<>" @@ -214,13 +227,20 @@ instance PPA LinValue where where alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss))) 2 ("=>"<+>lv) - StrConstant s -> doubleQuotes s -- hmm TableValue _ tvs -> "table"<+>block tvs -- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts) TupleValue lvs -> "<"<>punctuate "," lvs<>">" VarValue v -> pp v _ -> parens lv +instance Pretty LinLiteral where pp = ppA + +instance PPA LinLiteral where + ppA l = case l of + FloatConstant f -> pp f + IntConstant n -> pp n + StrConstant s -> doubleQuotes s -- hmm + instance RhsSeparator LinValue where rhsSep _ = pp "=" instance Pretty LinPattern where @@ -250,11 +270,17 @@ instance Pretty CatId where pp (CatId s) = pp s instance Pretty FunId where pp (FunId s) = pp s instance Pretty LabelId where pp (LabelId s) = pp s instance Pretty PredefId where pp = ppA -instance PPA PredefId where ppA (PredefId s) = pp s +instance PPA PredefId where ppA (PredefId s) = "Predef."<>s instance Pretty ParamId where pp = ppA instance PPA ParamId where ppA (ParamId s) = pp s instance Pretty VarValueId where pp (VarValueId s) = pp s +instance Pretty QualId where pp = ppA + +instance PPA QualId where + ppA (Qual m n) = m<>"_"<>n -- hmm + ppA (Unqual n) = pp n + instance Pretty Flags where pp (Flags []) = empty pp (Flags flags) = "flags" <+> vcat (map ppFlag flags) diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs index d791e0d9b..c14716eea 100644 --- a/src/compiler/GF/Grammar/CanonicalJSON.hs +++ b/src/compiler/GF/Grammar/CanonicalJSON.hs @@ -95,10 +95,7 @@ instance JSON LinType where instance JSON LinValue where showJSON lv = case lv of - -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: - StrConstant s -> showJSON s - FloatConstant f -> showJSON f - IntConstant n -> showJSON n + LiteralValue l -> showJSON l -- concatenation is encoded as a JSON array: ConcatValue v v' -> showJSON [showJSON v, showJSON v'] -- most values are encoded as JSON objects: @@ -115,6 +112,13 @@ instance JSON LinValue where -- records are encoded directly as JSON records: RecordValue rows -> showJSON rows +instance JSON LinLiteral where + showJSON l = case l of + -- basic values (Str, Float, Int) are encoded as JSON strings/numbers: + StrConstant s -> showJSON s + FloatConstant f -> showJSON f + IntConstant n -> showJSON n + instance JSON LinPattern where showJSON linpat = case linpat of -- wildcards and patterns without arguments are encoded as strings: @@ -161,6 +165,10 @@ instance JSON VarId where showJSON Anonymous = showJSON "_" showJSON (VarId x) = showJSON x +instance JSON QualId where + showJSON (Qual (ModId m) n) = showJSON (m++"_"++n) + showJSON (Unqual n) = showJSON n + instance JSON Flags where -- flags are encoded directly as JSON records (i.e., objects): showJSON (Flags fs) = makeObj [(f,showJSON v) | (f, v) <- fs]