msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Make GF.Grammar.Canonical.Id a type synonym for GF.Infra.Ident.RawIdent

Browse Source 
This avoids a lot of conversion back and forth between Strings and ByteStrings

This commit was cherry-picked from d0c27cdaae (lpgf branch)
This commit is contained in:
John J. Camilleri
2021-06-30 10:58:23 +02:00
parent 6efbd23c5c
commit 0a70eca6e2
5 changed files with 86 additions and 76 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -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
@@ -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]
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

24
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -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(optionsPGF)
import PGF.Internal(Literal(..))
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
@@ -188,7 +188,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
@@ -357,16 +357,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
@@ -375,11 +379,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 =

3
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -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)
--------------------------------------------------------------------------------

17
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -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 ()
@@ -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)]
@@ -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
src/compiler/GF/Infra/Ident.hs
View File

@@ -77,7 +77,6 @@ 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