mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Make GF.Grammar.Canonical.Id a type synonym for GF.Infra.Ident.RawIdent
This avoids a lot of conversion back and forth between Strings and ByteStrings
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -16,7 +16,7 @@ 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.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent)
|
||||
import GF.Infra.Option(Options, optionsPGF)
|
||||
import PGF.Internal(Literal(..))
|
||||
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
|
||||
@@ -70,8 +70,8 @@ concretes2canonical opts absname gr =
|
||||
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) .
|
||||
M.toList $
|
||||
@@ -189,7 +189,7 @@ 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
|
||||
@@ -248,7 +248,7 @@ projection r l = maybe (Projection r l) id (proj r l)
|
||||
|
||||
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
|
||||
@@ -258,7 +258,7 @@ 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
|
||||
@@ -358,16 +358,20 @@ paramType gr q@(_,n) =
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
@@ -376,11 +380,11 @@ 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)
|
||||
qual m n = Qual (modId m) (ident2raw n)
|
||||
unqual n = Unqual (ident2raw n)
|
||||
|
||||
convFlags gr mn =
|
||||
Flags [(n,convLit v) |
|
||||
Flags [(rawIdentS n,convLit v) |
|
||||
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
|
||||
where
|
||||
convLit l =
|
||||
|
||||
@@ -10,6 +10,7 @@ import GF.Compile.GrammarToCanonical (grammar2canonical)
|
||||
|
||||
import GF.Data.Operations (ErrorMonad (..))
|
||||
import qualified GF.Data.IntMapBuilder as IntMapBuilder
|
||||
import GF.Infra.Ident (rawIdentS, showRawIdent)
|
||||
import GF.Infra.Option (Options)
|
||||
import GF.Infra.UseIO (IOE)
|
||||
import GF.Text.Pretty (pp, render)
|
||||
@@ -63,10 +64,10 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
|
||||
lincats :: [C.LincatDef]
|
||||
lincats = s:i:f:lincats0
|
||||
where
|
||||
ss = C.RecordType [C.RecordRow (C.LabelId "s") C.StrType]
|
||||
s = C.LincatDef (C.CatId "String") ss
|
||||
i = C.LincatDef (C.CatId "Int") ss
|
||||
f = C.LincatDef (C.CatId "Float") ss
|
||||
ss = C.RecordType [C.RecordRow (C.LabelId (rawIdentS "s")) C.StrType]
|
||||
s = C.LincatDef (C.CatId (rawIdentS "String")) ss
|
||||
i = C.LincatDef (C.CatId (rawIdentS "Int")) ss
|
||||
f = C.LincatDef (C.CatId (rawIdentS "Float")) ss
|
||||
|
||||
lindefs :: [C.LinDef]
|
||||
lindefs =
|
||||
@@ -108,7 +109,7 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
|
||||
Just d -> Right d
|
||||
Nothing ->
|
||||
-- Left $ printf "Cannot find param definition: %s" (show pid)
|
||||
Right $ C.ParamDef (C.ParamId (C.Unqual "DUMMY")) [C.Param pid []]
|
||||
Right $ C.ParamDef (C.ParamId (C.Unqual (rawIdentS "DUMMY"))) [C.Param pid []]
|
||||
|
||||
-- | Lookup lintype for a function
|
||||
lookupLinType :: C.FunId -> Either String C.LinType
|
||||
@@ -171,13 +172,13 @@ mkConcrete debug (C.Abstract _ _ _ funs) (C.Concrete modId absModId flags params
|
||||
let (C.ParamDef tpid _) = def
|
||||
return (term, Just $ C.ParamType (C.ParamTypeId tpid))
|
||||
|
||||
C.PredefValue (C.PredefId pid) -> case pid of
|
||||
C.PredefValue (C.PredefId pid) -> case showRawIdent pid of
|
||||
"BIND" -> return (L.Bind, Nothing)
|
||||
"SOFT_BIND" -> return (L.Bind, Nothing)
|
||||
"SOFT_SPACE" -> return (L.Space, Nothing)
|
||||
"CAPIT" -> return (L.Capit, Nothing)
|
||||
"ALL_CAPIT" -> return (L.AllCapit, Nothing)
|
||||
_ -> Left $ printf "Unknown predef function: %s" pid
|
||||
x -> Left $ printf "Unknown predef function: %s" x
|
||||
|
||||
C.RecordValue rrvs -> do
|
||||
let rrvs' = sortRecordRows rrvs
|
||||
@@ -332,7 +333,7 @@ sortRecordRows :: [C.RecordRowValue] -> [C.RecordRowValue]
|
||||
sortRecordRows = L.sortBy ordLabel
|
||||
where
|
||||
ordLabel (C.RecordRow (C.LabelId l1) _) (C.RecordRow (C.LabelId l2) _) =
|
||||
case (l1,l2) of
|
||||
case (showRawIdent l1, showRawIdent l2) of
|
||||
("s",_) -> LT
|
||||
(_,"s") -> GT
|
||||
(s1,s2) -> compare s1 s2
|
||||
@@ -407,13 +408,13 @@ eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
|
||||
eitherElemIndex x xs = m2e (printf "Cannot find: %s in %s" (show x) (show xs)) (elemIndex x xs)
|
||||
|
||||
mdi2s :: C.ModId -> String
|
||||
mdi2s (C.ModId i) = i
|
||||
mdi2s (C.ModId i) = showRawIdent i
|
||||
|
||||
mdi2i :: C.ModId -> CId
|
||||
mdi2i (C.ModId i) = mkCId i
|
||||
mdi2i (C.ModId i) = mkCId (showRawIdent i)
|
||||
|
||||
fi2i :: C.FunId -> CId
|
||||
fi2i (C.FunId i) = mkCId i
|
||||
fi2i (C.FunId i) = mkCId (showRawIdent i)
|
||||
|
||||
-- Debugging
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -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:
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -160,6 +160,11 @@ Max memory: 619.71 MB
|
||||
- size: 2.48 MB Phrasebook.lpgf
|
||||
Max memory: 1.15 GB
|
||||
|
||||
**RawIdents**
|
||||
- compile: 5.393466s
|
||||
- size: 3.01 MB Phrasebook.lpgf
|
||||
Max memory: 1.12 GB
|
||||
|
||||
### Repeated terms in compilation
|
||||
|
||||
**Param and Table**
|
||||
|
||||
Reference in New Issue
Block a user