summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Compile/ConcreteToHaskell.hs47
-rw-r--r--src/compiler/GF/Compile/GrammarToCanonical.hs146
-rw-r--r--src/compiler/GF/Grammar/Canonical.hs3
-rw-r--r--src/compiler/GF/Grammar/CanonicalJSON.hs37
-rw-r--r--src/compiler/GF/Grammar/Macros.hs38
-rw-r--r--src/compiler/GF/Infra/Ident.hs39
6 files changed, 183 insertions, 127 deletions
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index d74fcdacd..c9f0438e6 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -7,7 +7,7 @@ import GF.Text.Pretty
--import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
import GF.Infra.Option
import GF.Haskell as H
import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
| let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs,
let ModId name = concName cncmod
- filename = name ++ ".hs" :: FilePath
+ filename = showRawIdent name ++ ".hs" :: FilePath
]
-- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
labels = S.difference (S.unions (map S.fromList recs)) common_labels
common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s]
- label_s = LabelId "s"
+ label_s = LabelId (rawIdentS "s")
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where
@@ -69,7 +69,7 @@ concrete2haskell opts
where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats]
-
+
gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent
@@ -116,7 +116,7 @@ concrete2haskell opts
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt)
--- TupleType lts ->
+-- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
@@ -126,7 +126,7 @@ concrete2haskell opts
linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
- linDef (LinDef f xs rhs0) =
+ linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs)))
where
lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
where
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)))
@@ -187,7 +187,7 @@ concrete2haskell opts
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
-
+
table cs =
if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
-- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t =
- case (ty,t) of
+ case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
- RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
+ RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
(RecordType rt,VarValue x)->
case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,18 +334,17 @@ coerce env ty t =
_ -> t
where
app f ts = ParamConstant (Param f ts) -- !! a hack
- to_rcon = ParamId . Unqual . to_rcon' . labels
+ to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
patVars p = []
-labels r = [l|RecordRow l _<-r]
+labels r = [l | RecordRow l _ <- r]
proj = Var . identS . proj'
-proj' (LabelId l) = "proj_"++l
+proj' (LabelId l) = "proj_" ++ showRawIdent l
rcon = Var . rcon'
rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
-
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
to_rcon' = ("to_"++) . rcon_name
recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
-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 q) = qIdentS q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
+instance ToIdent CatId where toIdent (CatId s) = identC s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
-qIdentS = identS . unqual
+qIdentC = identS . unqual
-unqual (Qual (ModId m) n) = m++"_"++n
-unqual (Unqual n) = n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
+unqual (Unqual n) = showRawIdent n
instance ToIdent VarId where
toIdent Anonymous = identW
- toIdent (VarId s) = identS s
+ toIdent (VarId s) = identC s
diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 33f35ad08..a600573ac 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
) where
import Data.List(nub,partition)
import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Text.Pretty
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar as G
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
import GF.Grammar.Lockfield(isLockLabel)
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.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
+import GF.Infra.Option(Options,optionsPGF)
import PGF.Internal(Literal(..))
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
import GF.Grammar.Canonical as C
-import Debug.Trace
+import System.FilePath ((</>), (<.>))
+import qualified Debug.Trace as T
+
-- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
grammar2canonical opts absname gr =
Grammar (abstract2canonical absname gr)
(map snd (concretes2canonical opts absname gr))
-- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
abstract2canonical absname gr =
Abstract (modId absname) (convFlags gr absname) cats funs
where
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
convHypo (bt,name,t) =
case typeForm t of
([],(_,cat),[]) -> gId cat -- !!
+ tf -> error $ "abstract2canonical convHypo: " ++ show tf
convType t =
case typeForm t of
@@ -54,25 +60,26 @@ abstract2canonical absname gr =
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
-
-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical opts absname gr =
[(cncname,concrete2canonical gr cenv absname cnc cncmod)
| let cenv = resourceValues opts gr,
cnc<-allConcretes gr absname,
- let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
+ let cncname = "canonical" </> render cnc <.> "gf"
Ok cncmod = lookupModule gr cnc
]
-- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical gr cenv absname cnc modinfo =
Concrete (modId cnc) (modId absname) (convFlags gr cnc)
(neededParamTypes S.empty (params defs))
- [lincat|(_,Left lincat)<-defs]
- [lin|(_,Right lin)<-defs]
+ [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
@@ -85,6 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
else let ((got,need),def) = paramType gr q
in def++neededParamTypes (S.union got have) (S.toList need++qs)
+toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
toCanonical gr absname cenv (name,jment) =
case jment of
CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -97,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
where
tts = tableTypes gr [e']
- e' = unAbs (length params) $
+ e' = cleanupRecordFields lincat $
+ unAbs (length params) $
nf loc (mkAbs params (mkApp def (map Vr args)))
params = [(b,x)|(b,x,_)<-ctx]
args = map snd params
@@ -108,12 +117,12 @@ toCanonical gr absname cenv (name,jment) =
_ -> []
where
nf loc = normalForm cenv (L loc name)
--- aId n = prefixIdent "A." (gId n)
unAbs 0 t = t
unAbs n (Abs _ _ t) = unAbs (n-1) t
unAbs _ t = t
+tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
tableTypes gr ts = S.unions (map tabtys ts)
where
tabtys t =
@@ -122,6 +131,7 @@ tableTypes gr ts = S.unions (map tabtys ts)
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
_ -> collectOp tabtys t
+paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -140,11 +150,26 @@ paramTypes gr t =
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
- ignore = trace ("Ignore: "++show t) S.empty
-
-
+ ignore = T.trace ("Ignore: " ++ show t) S.empty
+
+-- | Filter out record fields from definitions which don't appear in lincat.
+cleanupRecordFields :: G.Type -> Term -> Term
+cleanupRecordFields (RecType ls) (R as) =
+ let defnFields = M.fromList ls
+ in R
+ [ (lbl, (mty, t'))
+ | (lbl, (mty, t)) <- as
+ , M.member lbl defnFields
+ , let Just ty = M.lookup lbl defnFields
+ , let t' = cleanupRecordFields ty t
+ ]
+cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
+cleanupRecordFields _ t = t
+
+convert :: G.Grammar -> Term -> LinValue
convert gr = convert' gr []
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
convert' gr vs = ppT
where
ppT0 = convert' gr vs
@@ -162,20 +187,20 @@ convert' gr vs = ppT
S t p -> selection (ppT t) (ppT p)
C t1 t2 -> concatValue (ppT t1) (ppT t2)
App f a -> ap (ppT f) (ppT a)
- R r -> RecordValue (fields r)
+ R r -> RecordValue (fields (sortRec r))
P t l -> projection (ppT t) (lblId l)
Vr x -> VarValue (gId x)
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
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)) [])
+ 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
+ _ -> error $ "convert' ppT: " ++ show t
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
@@ -188,12 +213,12 @@ convert' gr vs = ppT
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gQId cPredef n) -- hmm
where
- p = PredefValue . PredefId
-
+ p = PredefValue . PredefId . rawIdentS
+
ppP p =
case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
- PP (m,c) ps -> ParamPattern (Param ((gQId 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
@@ -202,6 +227,7 @@ convert' gr vs = ppT
PFloat x -> Lit (show x)
PT _ p -> ppP p
PAs x p -> AsP x (ppP p) -}
+ _ -> error $ "convert' ppP: " ++ show p
where
fields = map field . filter (not.isLockLabel.fst)
field (l,p) = RecordRow (lblId l) (ppP p)
@@ -218,12 +244,12 @@ convert' gr vs = ppT
pre Empty = [""] -- Empty == K ""
pre (Strs ts) = concatMap pre ts
pre (EPatt p) = pat p
- pre t = error $ "pre "++show t
+ pre t = error $ "convert' alts pre: " ++ show t
pat (PString s) = [s]
pat (PAlt p1 p2) = pat p1++pat p2
pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
- pat p = error $ "pat "++show p
+ pat p = error $ "convert' alts pat: "++show p
fields = map field . filter (not.isLockLabel.fst)
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -236,6 +262,7 @@ convert' gr vs = ppT
ParamConstant (Param p (ps++[a]))
_ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
+concatValue :: LinValue -> LinValue -> LinValue
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
@@ -243,21 +270,24 @@ concatValue v1 v2 =
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
-projection r l = maybe (Projection r l) id (proj r l)
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
+proj :: LinValue -> LabelId -> Maybe LinValue
proj r l =
case r of
- RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
+ RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
[v] -> Just v
_ -> Nothing
_ -> Nothing
-- | Smart constructor for selections
+selection :: LinValue -> LinValue -> LinValue
selection t v =
-- Note: impossible cases can become possible after grammar transformation
case t of
TableValue tt r ->
- case nub [rv|TableRow _ rv<-keep] of
+ case nub [rv | TableRow _ rv <- keep] of
[rv] -> rv
_ -> Selection (TableValue tt r') v
where
@@ -276,13 +306,16 @@ selection t v =
(keep,discard) = partition (mightMatchRow v) r
_ -> Selection t v
+impossible :: LinValue -> LinValue
impossible = CommentedValue "impossible"
+mightMatchRow :: LinValue -> TableRow rhs -> Bool
mightMatchRow v (TableRow p _) =
case p of
WildPattern -> True
_ -> mightMatch v p
+mightMatch :: LinValue -> LinPattern -> Bool
mightMatch v p =
case v of
ConcatValue _ _ -> False
@@ -294,16 +327,18 @@ mightMatch v p =
RecordValue rv ->
case p of
RecordPattern rp ->
- and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+ and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
_ -> False
_ -> True
+patVars :: Patt -> [Ident]
patVars p =
case p of
PV x -> [x]
PAs x p -> x:patVars p
_ -> collectPattOp patVars p
+convType :: Term -> LinType
convType = ppT
where
ppT t =
@@ -315,9 +350,9 @@ 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 ((gQId m n)))
- Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
- _ -> error $ "Missing case in convType for: "++show t
+ QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+ Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+ _ -> error $ "convType ppT: " ++ show t
convFields = map convField . filter (not.isLockLabel.fst)
convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -326,15 +361,20 @@ convType = ppT
"Float" -> FloatType
"Int" -> IntType
"Str" -> StrType
- _ -> error ("convSort "++show k)
+ _ -> error $ "convType convSort: " ++ show k
+toParamType :: Term -> ParamType
toParamType t = case convType t of
ParamType pt -> pt
- _ -> error ("toParamType "++show t)
+ _ -> error $ "toParamType: " ++ show t
+toParamId :: Term -> ParamId
toParamId t = case toParamType t of
ParamTypeId p -> p
+paramType :: G.Grammar
+ -> (ModuleName, Ident)
+ -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
paramType gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
@@ -342,7 +382,7 @@ paramType gr q@(_,n) =
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
- where name = (gQId m n)
+ where name = gQId m n
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {-
@@ -350,36 +390,46 @@ paramType gr q@(_,n) =
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
- [ParamAliasDef ((gQId m n)) (convType t)])
+ [ParamAliasDef (gQId m n) (convType t)])
_ -> ((S.empty,S.empty),[])
where
- param m (n,ctx) = Param ((gQId 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]
-lblId = LabelId . render -- hmm
-modId (MN m) = ModId (showIdent m)
+lblId :: Label -> C.LabelId
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
+
+modId :: ModuleName -> C.ModId
+modId (MN m) = ModId (ident2raw m)
-class FromIdent i where gId :: Ident -> i
+class FromIdent i where
+ gId :: Ident -> i
instance FromIdent VarId where
- gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
+ gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
-instance FromIdent C.FunId where gId = C.FunId . showIdent
-instance FromIdent CatId where gId = CatId . showIdent
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
+instance FromIdent CatId where gId = CatId . ident2raw
instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual
-class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
+class FromIdent i => QualIdent i where
+ gQId :: ModuleName -> Ident -> i
-instance QualIdent ParamId where gQId m n = ParamId (qual m n)
+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)
+qual :: ModuleName -> Ident -> QualId
+qual m n = Qual (modId m) (ident2raw n)
+
+unqual :: Ident -> QualId
+unqual n = Unqual (ident2raw n)
+convFlags :: G.Grammar -> ModuleName -> Flags
convFlags gr mn =
- Flags [(n,convLit v) |
+ Flags [(rawIdentS n,convLit v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where
convLit l =
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 0df3236ff..80e9f5e7b 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -11,6 +11,7 @@
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
+import GF.Infra.Ident (RawIdent)
-- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
-type Id = String
+type Id = RawIdent
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
--------------------------------------------------------------------------------
diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs
index 0ec7f43e6..04c13df5e 100644
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/src/compiler/GF/Grammar/CanonicalJSON.hs
@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
import Control.Monad (guard)
+import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
encodeJSON :: FilePath -> Grammar -> IO ()
@@ -29,7 +30,7 @@ instance JSON Grammar where
-- ** Abstract Syntax
instance JSON Abstract where
- showJSON (Abstract absid flags cats funs)
+ showJSON (Abstract absid flags cats funs)
= makeObj [("abs", showJSON absid),
("flags", showJSON flags),
("cats", showJSON cats),
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
-- ** Concrete syntax
instance JSON Concrete where
- showJSON (Concrete cncid absid flags params lincats lins)
+ showJSON (Concrete cncid absid flags params lincats lins)
= makeObj [("cnc", showJSON cncid),
("abs", showJSON absid),
("flags", showJSON flags),
@@ -204,12 +205,12 @@ instance JSON a => JSON (RecordRow a) where
-- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
showJSON row = showJSONs [row]
showJSONs rows = makeObj (map toRow rows)
- where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
+ where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
readJSON obj = head <$> readJSONs obj
readJSONs obj = mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
- return (RecordRow (LabelId lbl) value)
+ return (RecordRow (LabelId (rawIdentS lbl)) value)
instance JSON rhs => JSON (TableRow rhs) where
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where
-- *** Identifiers in Concrete Syntax
-instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
-instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
-instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
-instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
-instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
+instance JSON PredefId where showJSON (PredefId s) = showJSON s ; readJSON = fmap PredefId . readJSON
+instance JSON LabelId where showJSON (LabelId s) = showJSON s ; readJSON = fmap LabelId . readJSON
+instance JSON VarValueId where showJSON (VarValueId s) = showJSON s ; readJSON = fmap VarValueId . readJSON
+instance JSON ParamId where showJSON (ParamId s) = showJSON s ; readJSON = fmap ParamId . readJSON
+instance JSON ParamType where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
--------------------------------------------------------------------------------
-- ** Used in both Abstract and Concrete Syntax
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
instance JSON VarId where
-- the anonymous variable is the underscore:
@@ -242,20 +243,24 @@ instance JSON VarId where
<|> VarId <$> readJSON o
instance JSON QualId where
- showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
+ showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
showJSON (Unqual n) = showJSON n
readJSON o = do qualid <- readJSON o
let (mod, id) = span (/= '.') qualid
- return $ if null mod then Unqual id else Qual (ModId mod) id
+ return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
+
+instance JSON RawIdent where
+ showJSON i = showJSON $ showRawIdent i
+ readJSON o = rawIdentS <$> readJSON o
instance JSON Flags where
-- flags are encoded directly as JSON records (i.e., objects):
- showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
+ showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
- return (lbl, value)
+ return (rawIdentS lbl, value)
instance JSON FlagValue where
-- flag values are encoded as basic JSON types:
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index b088fe49c..280aee141 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/11 16:38:00 $
+-- > CVS $Date: 2005/11/11 16:38:00 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.24 $
--
@@ -51,14 +51,14 @@ typeForm t =
_ -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t =
+typeFormCnc t =
case t of
Prod b x a t -> let (x', v) = typeFormCnc t
in ((b,x,a):x',v)
_ -> ([],t)
valCat :: Type -> Cat
-valCat typ =
+valCat typ =
let (_,cat,_) = typeForm typ
in cat
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do -- pessimistic choice
contextOfType :: Monad m => Type -> m Context
contextOfType typ = case typ of
Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
- _ -> return []
+ _ -> return []
termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
return ((b,x):x', fun, args)
App c a ->
do (_,fun, args) <- termForm c
- return ([],fun,args ++ [a])
- _ ->
+ return ([],fun,args ++ [a])
+ _ ->
return ([],t,[])
termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
mkTable tt t = foldr Table t tt
mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where
+mkCTable ids v = foldr ccase v ids where
ccase (_,x) t = T TRaw [(PV x,t)]
mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
filter (`elem` (map fst r1)) (map fst r2) of
[] -> return (RecType (r1 ++ r2))
ls -> raise $ render ("clashing labels" <+> hsep ls)
- _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
+ _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
--plusRecord :: Term -> Term -> Err Term
plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel, typeStr)]
-- | refreshing variables
mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1)
+mkFreshVar olds = varX (maxVarIndex olds + 1)
-- | trying to preserve a given symbol
mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
maxVarIndex :: [Ident] -> Int
maxVarIndex = maximum . ((-1):) . map varIndex
-mkFreshVars :: Int -> [Ident] -> [Ident]
+mkFreshVars :: Int -> [Ident] -> [Ident]
mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
-- | quick hack for refining with var in editor
@@ -413,11 +413,11 @@ patt2term pt = case pt of
PC c pp -> mkApp (Con c) (map patt2term pp)
PP c pp -> mkApp (QC c) (map patt2term pp)
- PR r -> R [assign l (patt2term p) | (l,p) <- r]
+ PR r -> R [assign l (patt2term p) | (l,p) <- r]
PT _ p -> patt2term p
PInt i -> EInt i
PFloat i -> EFloat i
- PString s -> K s
+ PString s -> K s
PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
PChar -> appCons cChar [] --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
-- | to define compositional term functions
composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm =
+composOp co trm =
case trm of
App c a -> liftM2 App (co c) (co a)
Abs b x t -> liftM (Abs b x) (co t)
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
v0 <- mapM (strsFromTerm . fst) vs
c0 <- mapM (strsFromTerm . snd) vs
--let vs' = zip v0 c0
- return [strTok (str2strings def) vars |
+ return [strTok (str2strings def) vars |
def <- d0,
- vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+ vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
vv <- sequence v0]
]
FV ts -> mapM strsFromTerm ts >>= return . concat
- Strs ts -> mapM strsFromTerm ts >>= return . concat
+ Strs ts -> mapM strsFromTerm ts >>= return . concat
_ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
getTableType :: TInfo -> Err Type
@@ -590,11 +590,11 @@ noExist = FV []
defaultLinType :: Type
defaultLinType = mkRecType linLabel [typeStr]
--- normalize records and record types; put s first
+-- | normalize records and record types; put s first
sortRec :: [(Label,a)] -> [(Label,a)]
sortRec = sortBy ordLabel where
- ordLabel (r1,_) (r2,_) =
+ ordLabel (r1,_) (r2,_) =
case (showIdent (label2ident r1), showIdent (label2ident r2)) of
("s",_) -> LT
(_,"s") -> GT
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
-allDependencies ism b =
+allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
where
opersIn t = case t of
diff --git a/src/compiler/GF/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs
index b856d3995..ad47d91cd 100644
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/src/compiler/GF/Infra/Ident.hs
@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
--- > CVS $Date: 2005/11/15 11:43:33 $
+-- > CVS $Date: 2005/11/15 11:43:33 $
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.8 $
--
@@ -13,18 +13,18 @@
-----------------------------------------------------------------------------
module GF.Infra.Ident (-- ** Identifiers
- ModuleName(..), moduleNameS,
- Ident, ident2utf8, showIdent, prefixIdent,
- -- *** Normal identifiers (returned by the parser)
- identS, identC, identW,
- -- *** Special identifiers for internal use
- identV, identA, identAV,
- argIdent, isArgIdent, getArgIndex,
- varStr, varX, isWildIdent, varIndex,
- -- *** Raw identifiers
- RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
- isPrefixOf, showRawIdent
- ) where
+ ModuleName(..), moduleNameS,
+ Ident, ident2utf8, showIdent, prefixIdent,
+ -- *** Normal identifiers (returned by the parser)
+ identS, identC, identW,
+ -- *** Special identifiers for internal use
+ identV, identA, identAV,
+ argIdent, isArgIdent, getArgIndex,
+ varStr, varX, isWildIdent, varIndex,
+ -- *** Raw identifiers
+ RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+ isPrefixOf, showRawIdent
+) where
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
-data Ident =
+data Ident =
IC {-# UNPACK #-} !RawIdent -- ^ raw identifier after parsing, resolved in Rename
| IW -- ^ wildcard
--
@@ -54,7 +54,7 @@ data Ident =
| IV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ variable
| IA {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat at position
| IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int -- ^ /INTERNAL/ argument of cat with bindings at position
---
+--
deriving (Eq, Ord, Show, Read)
-- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
rawIdentC = Id
showRawIdent = unpack . rawId2utf8
-prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
instance Binary RawIdent where
put = put . rawId2utf8
get = fmap rawIdentC get
-
-- | This function should be used with care, since the returned ByteString is
-- UTF-8-encoded.
ident2utf8 :: Ident -> UTF8.ByteString
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
IW -> pack "_"
+ident2raw :: Ident -> RawIdent
ident2raw = Id . ident2utf8
showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
instance Pretty Ident where pp = pp . showIdent
+instance Pretty RawIdent where pp = pp . showRawIdent
+
identS :: String -> Ident
identS = identC . rawIdentS
identC :: RawIdent -> Ident
identW :: Ident
-
prefixIdent :: String -> Ident -> Ident
prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
identA :: RawIdent -> Int -> Ident
identAV:: RawIdent -> Int -> Int -> Ident
-(identC, identV, identA, identAV, identW) =
+(identC, identV, identA, identAV, identW) =
(IC, IV, IA, IAV, IW)
-- | to mark argument variables
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:21:46 +0000