forked from GitHub/gf-core
the JSON dump now supports the entire GF language
This commit is contained in:
Krasimir Angelov
@@ -3,91 +3,76 @@ module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
|
||||
|
||||
import PGF2(Literal(..))
|
||||
import Data.List(isPrefixOf,sort,sortOn)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as Map
|
||||
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,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
|
||||
import GF.Grammar.Predef
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Macros
|
||||
import GF.Infra.Ident
|
||||
import GF.Infra.Option
|
||||
import GF.Haskell as H
|
||||
import GF.Grammar.Canonical as C
|
||||
import GF.Compile.GrammarToCanonical
|
||||
import Debug.Trace(trace)
|
||||
|
||||
-- | Generate Haskell code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2haskell opts absname gr = do
|
||||
Grammar abstr cncs <- grammar2canonical opts absname gr
|
||||
return [(filename,render80 $ concrete2haskell opts abstr cncmod)
|
||||
| cncmod<-cncs,
|
||||
let ModId name = concName cncmod
|
||||
filename = showRawIdent name ++ ".hs" :: FilePath
|
||||
gr <- grammar2canonical opts absname gr
|
||||
let abstr:concrs = modules gr
|
||||
return [(filename,render80 $ concrete2haskell opts abstr concr)
|
||||
| concr@(MN mn,_) <- concrs,
|
||||
let filename = showIdent mn ++ ".hs" :: FilePath
|
||||
]
|
||||
|
||||
-- | Generate Haskell code for the given concrete module.
|
||||
-- The only options that make a difference are
|
||||
-- @-haskell=noprefix@ and @-haskell=variants@.
|
||||
concrete2haskell opts
|
||||
abstr@(Abstract _ _ cats funs)
|
||||
modinfo@(Concrete cnc absname _ ps lcs lns) =
|
||||
haskPreamble absname cnc $$
|
||||
concrete2haskell opts abstr@(absname,_) concr@(cncname,mi) =
|
||||
haskPreamble absname cncname $$
|
||||
vcat (
|
||||
nl:Comment "--- Parameter types ---":
|
||||
map paramDef ps ++
|
||||
[paramDef id ps | (id,ResParam (Just (L _ ps)) _) <- Map.toList (jments mi)] ++
|
||||
nl:Comment "--- Type signatures for linearization functions ---":
|
||||
map signature cats ++
|
||||
nl:Comment "--- Linearization functions for empty categories ---":
|
||||
emptydefs ++
|
||||
[signature id | (id,CncCat _ _ _ _ _) <- Map.toList (jments mi)] ++
|
||||
nl:Comment "--- Linearization types ---":
|
||||
map lincatDef lcs ++
|
||||
[lincatDef id ty | (id,CncCat (Just (L _ ty)) _ _ _ _) <- Map.toList (jments mi)] ++
|
||||
nl:Comment "--- Linearization functions ---":
|
||||
lindefs ++
|
||||
concat (Map.elems lindefs) ++
|
||||
nl:Comment "--- Type classes for projection functions ---":
|
||||
map labelClass (S.toList labels) ++
|
||||
-- map labelClass (S.toList labels) ++
|
||||
nl:Comment "--- Record types ---":
|
||||
concatMap recordType recs)
|
||||
[] -- concatMap recordType recs
|
||||
)
|
||||
where
|
||||
nl = Comment ""
|
||||
recs = S.toList (S.difference (records (lcs,lns)) common_records)
|
||||
|
||||
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 (rawIdentS "s")
|
||||
|
||||
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
|
||||
signature c = TypeSig lf (Fun abs (pure lin))
|
||||
where
|
||||
abs = tcon0 (prefixIdent "A." (gId c))
|
||||
lin = tcon0 lc
|
||||
lf = linfunName c
|
||||
lc = lincatName c
|
||||
|
||||
emptydefs = map emptydef (S.toList emptyCats)
|
||||
emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
|
||||
|
||||
emptyCats = allcats `S.difference` linfuncats
|
||||
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 :: Ident -> Ident
|
||||
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
|
||||
. toIdent
|
||||
|
||||
va = haskellOption opts HaskellVariants
|
||||
pure = if va then ListT else id
|
||||
|
||||
haskPreamble :: ModId -> ModId -> Doc
|
||||
haskPreamble :: ModuleName -> ModuleName -> Doc
|
||||
haskPreamble absname cncname =
|
||||
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
|
||||
"module" <+> cncname <+> "where" $$
|
||||
"import Prelude hiding (Ordering(..))" $$
|
||||
"import Control.Applicative((<$>),(<*>))" $$
|
||||
"import PGF.Haskell" $$
|
||||
"import qualified" <+> absname <+> "as A" $$
|
||||
"" $$
|
||||
"-- | Token sequences, output form linearization functions" $$
|
||||
"type Str = [Tok] -- token sequence" $$
|
||||
"" $$
|
||||
"-- | Tokens" $$
|
||||
"data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT" $$
|
||||
" deriving (Eq,Ord,Show)" $$
|
||||
"" $$
|
||||
"--- Standard definitions ---" $$
|
||||
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
|
||||
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
|
||||
@@ -99,319 +84,122 @@ concrete2haskell opts
|
||||
where
|
||||
pure = if va then brackets else pp
|
||||
|
||||
paramDef pd =
|
||||
case pd of
|
||||
ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
|
||||
ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
|
||||
where
|
||||
paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
|
||||
derive = ["Eq","Ord","Show"]
|
||||
|
||||
convLinType = ppT
|
||||
paramDef id pvs = Data (conap0 (gId id)) (map paramCon pvs) derive
|
||||
where
|
||||
ppT t =
|
||||
case t of
|
||||
FloatType -> tcon0 (identS "Float")
|
||||
IntType -> tcon0 (identS "Int")
|
||||
ParamType (ParamTypeId p) -> tcon0 (gId p)
|
||||
RecordType rs -> tcon (rcon' ls) (map ppT ts)
|
||||
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 ->
|
||||
paramCon (id,ctxt) = ConAp (gId id) [tcon0 (gId cat) | (_,_,QC (_,cat)) <- ctxt]
|
||||
derive = ["Eq","Ord","Show"]
|
||||
|
||||
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
|
||||
convLinType (Sort s)
|
||||
| s == cStr = tcon0 (identS "Str")
|
||||
convLinType (QC (_,p)) = tcon0 (gId p)
|
||||
convLinType (RecType lbls) = tcon (rcon' ls) (map convLinType ts)
|
||||
where (ls,ts) = unzip $ sortOn fst lbls
|
||||
convLinType (Table pt lt) = Fun (convLinType pt) (convLinType lt)
|
||||
|
||||
linfuncats = S.fromList linfuncatl
|
||||
(linfuncatl,lindefs) = unzip (linDefs lns)
|
||||
lincatDef c ty = tsyn0 (lincatName c) (convLinType ty)
|
||||
|
||||
linDefs = map eqn . sortOn fst . map linDef
|
||||
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
|
||||
lindefs =
|
||||
Map.fromListWith (++)
|
||||
[linDef id absctx cat lincat rhs |
|
||||
(id,CncFun (Just (absctx,cat,_,lincat)) (Just (L _ rhs)) _ _) <- Map.toList (jments mi)]
|
||||
|
||||
linDef (LinDef f xs rhs0) =
|
||||
(cat,(linfunName cat,(lhs,rhs)))
|
||||
linDef f absctx cat lincat rhs0 =
|
||||
(cat,[Eqn (linfunName cat,lhs) rhs'])
|
||||
where
|
||||
lhs = [ConP (aId f) (map VarP abs_args)]
|
||||
aId f = prefixIdent "A." (gId f)
|
||||
|
||||
[lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
|
||||
[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
|
||||
--[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
|
||||
(xs,rhs) = termFormCnc rhs0
|
||||
|
||||
abs_args = map abs_arg args
|
||||
abs_arg = prefixIdent "abs_"
|
||||
args = map (prefixIdent "g" . toIdent) xs
|
||||
args = map (prefixIdent "g" . snd) xs
|
||||
|
||||
rhs = lets (zipWith letlin args absctx)
|
||||
(convert vs (coerce env lincat rhs0))
|
||||
rhs' = lets (zipWith letlin args absctx)
|
||||
(convert rhs)
|
||||
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)]
|
||||
vs = [(x,a)|((_,x),a)<-zip xs args]
|
||||
|
||||
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
|
||||
letlin a acat =
|
||||
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
|
||||
|
||||
arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
|
||||
where
|
||||
[lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
|
||||
|
||||
convert = convert' va
|
||||
|
||||
convert' va vs = ppT
|
||||
convert (Vr v) = Var (gId v)
|
||||
convert (EInt n) = lit n
|
||||
convert (EFloat d) = lit d
|
||||
convert (K s) = single (Const "TK" `Ap` lit s)
|
||||
convert Empty = List []
|
||||
convert (App t1 t2) = Ap (convert t1) (convert t2)
|
||||
convert (R lbls) = aps (rcon ls) (map (convert.snd) ts)
|
||||
where (ls,ts) = unzip (sortOn fst lbls)
|
||||
convert (P t lbl) = ap (proj lbl) (convert t)
|
||||
convert (ExtR t1 t2) = Const "ExtR" -- TODO
|
||||
convert (T _ cs) = LambdaCase (map ppCase cs)
|
||||
where
|
||||
ppT0 = convert' False vs
|
||||
ppTv vs' = convert' va vs'
|
||||
ppCase (p,t) = (convertPatt p,convert t)
|
||||
convert (V _ ts) = Const "V" -- TODO
|
||||
convert (S t p)
|
||||
| va = select_va (convert t) (convert p)
|
||||
| otherwise = Ap (convert t) (convert p)
|
||||
where
|
||||
select_va (List [t]) (List [p]) = Op t "!" p
|
||||
select_va (List [t]) p = Op t "!$" p
|
||||
select_va t p = Op t "!*" p
|
||||
convert (Q (_,id)) = single (Var id)
|
||||
convert (QC (_,id)) = single (Var id)
|
||||
convert (C t1 t2)
|
||||
| va = concat_va (convert t1) (convert t2)
|
||||
| otherwise = plusplus (convert t1) (convert t2)
|
||||
where
|
||||
concat_va (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
|
||||
concat_va t1 t2 = Op t1 "+++" t2
|
||||
convert (Glue t1 t2) = Const "Glue"
|
||||
convert (FV ts)
|
||||
| va = join (List (map convert ts))
|
||||
| otherwise = case ts of
|
||||
[] -> Const "error" `Ap` Const (show "empty variant")
|
||||
(t:ts) -> convert t
|
||||
where
|
||||
join (List [x]) = x
|
||||
join x = Const "concat" `Ap` x
|
||||
convert (Alts def alts) = single (Const "TP" `Ap` List (map convAlt alts) `Ap` convert def)
|
||||
where
|
||||
convAlt (t1,t2) = Pair (convert t1) (convert t2)
|
||||
convert (Strs ss) = List (map lit ss)
|
||||
convert t = error (show t)
|
||||
|
||||
pure = if va then single else id
|
||||
convertPatt (PC c ps) = ConP (gId c) (map convertPatt ps)
|
||||
convertPatt (PP (_,c) ps) = ConP (gId c) (map convertPatt ps)
|
||||
convertPatt (PV v) = VarP v
|
||||
convertPatt PW = WildP
|
||||
convertPatt (PR lbls) = ConP (rcon' ls) (map convertPatt ps)
|
||||
where (ls,ps) = unzip $ sortOn fst lbls
|
||||
convertPatt (PString s) = Lit s
|
||||
convertPatt (PT _ p) = convertPatt p
|
||||
convertPatt (PAs v p) = AsP v (convertPatt p)
|
||||
convertPatt (PImplArg p) = convertPatt p
|
||||
convertPatt (PTilde _) = WildP
|
||||
convertPatt (PAlt _ _) = WildP -- TODO
|
||||
convertPatt p = error (show p)
|
||||
|
||||
ppT t =
|
||||
case t of
|
||||
TableValue ty cs -> pure (table cs)
|
||||
Selection t p -> select (ppT t) (ppT p)
|
||||
ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
|
||||
RecordValue r -> aps (rcon ls) (map ppT ts)
|
||||
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
|
||||
PredefValue p -> single (Var (toIdent p)) -- hmm
|
||||
Projection t l -> ap (proj l) (ppT t)
|
||||
VariantValue [] -> empty
|
||||
VariantValue ts@(_:_) -> variants ts
|
||||
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
|
||||
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)
|
||||
lit s = Const (show s) -- hmm
|
||||
|
||||
ppL l =
|
||||
case l of
|
||||
LFlt x -> pure (lit x)
|
||||
LInt n -> pure (lit n)
|
||||
LStr s -> pure (token s)
|
||||
ap = if va then ap' else Ap
|
||||
where
|
||||
ap' (List [f]) x = fmap f x
|
||||
ap' f x = Op f "<*>" x
|
||||
fmap f (List [x]) = Ap f x
|
||||
fmap f x = Op f "<$>" x
|
||||
|
||||
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'])
|
||||
else LambdaCase (map ppCase cs)
|
||||
where
|
||||
(ds,ts') = dedup ts
|
||||
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
|
||||
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
|
||||
{-
|
||||
ppPredef n =
|
||||
case predef n of
|
||||
Ok BIND -> single (c "BIND")
|
||||
Ok SOFT_BIND -> single (c "SOFT_BIND")
|
||||
Ok SOFT_SPACE -> single (c "SOFT_SPACE")
|
||||
Ok CAPIT -> single (c "CAPIT")
|
||||
Ok ALL_CAPIT -> single (c "ALL_CAPIT")
|
||||
_ -> Var n
|
||||
-}
|
||||
ppP p =
|
||||
case p of
|
||||
ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
|
||||
RecordPattern r -> ConP (rcon' ls) (map ppP ps)
|
||||
where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
|
||||
WildPattern -> WildP
|
||||
|
||||
token s = single (c "TK" `Ap` lit s)
|
||||
|
||||
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
|
||||
where
|
||||
alt (s,t) = Pair (List (pre s)) (ppT0 t)
|
||||
pre s = map lit s
|
||||
|
||||
c = Const
|
||||
lit s = c (show s) -- hmm
|
||||
concat = if va then concat' else plusplus
|
||||
where
|
||||
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
|
||||
concat' t1 t2 = Op t1 "+++" t2
|
||||
|
||||
pure' = single -- forcing the list monad
|
||||
|
||||
select = if va then select' else Ap
|
||||
select' (List [t]) (List [p]) = Op t "!" p
|
||||
select' (List [t]) p = Op t "!$" p
|
||||
select' t p = Op t "!*" p
|
||||
|
||||
ap = if va then ap' else Ap
|
||||
where
|
||||
ap' (List [f]) x = fmap f x
|
||||
ap' f x = Op f "<*>" x
|
||||
fmap f (List [x]) = pure' (Ap f x)
|
||||
fmap f x = Op f "<$>" x
|
||||
|
||||
-- join = if va then join' else id
|
||||
join' (List [x]) = x
|
||||
join' x = c "concat" `Ap` x
|
||||
|
||||
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
|
||||
variants = if va then \ ts -> join' (List (map ppT ts))
|
||||
else \ (t:_) -> ppT t
|
||||
|
||||
aps f [] = f
|
||||
aps f (a:as) = aps (ap f a) as
|
||||
|
||||
dedup ts =
|
||||
if M.null dups
|
||||
then ([],map ppT ts)
|
||||
else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
|
||||
where
|
||||
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
|
||||
ev i = identS ("e'"++show i)
|
||||
|
||||
defs = [(i1,t)|(t,i1:_:_)<-ms]
|
||||
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
|
||||
ms = M.toList m
|
||||
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
|
||||
is = [0..]::[Int]
|
||||
|
||||
|
||||
--con = Cn . identS
|
||||
|
||||
class Records t where
|
||||
records :: t -> S.Set [LabelId]
|
||||
|
||||
instance Records t => Records [t] where
|
||||
records = S.unions . map records
|
||||
|
||||
instance (Records t1,Records t2) => Records (t1,t2) where
|
||||
records (t1,t2) = S.union (records t1) (records t2)
|
||||
|
||||
instance Records LincatDef where
|
||||
records (LincatDef _ lt) = records lt
|
||||
|
||||
instance Records LinDef where
|
||||
records (LinDef _ _ lv) = records lv
|
||||
|
||||
instance Records LinType where
|
||||
records t =
|
||||
case t of
|
||||
RecordType r -> rowRecords r
|
||||
TableType pt lt -> records (pt,lt)
|
||||
TupleType ts -> records ts
|
||||
_ -> S.empty
|
||||
|
||||
rowRecords r = S.insert (sort ls) (records ts)
|
||||
where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
|
||||
|
||||
instance Records LinValue where
|
||||
records v =
|
||||
case v of
|
||||
ConcatValue v1 v2 -> records (v1,v2)
|
||||
ParamConstant (Param c vs) -> records vs
|
||||
RecordValue r -> rowRecords r
|
||||
TableValue t r -> records (t,r)
|
||||
TupleValue vs -> records vs
|
||||
VariantValue vs -> records vs
|
||||
PreValue alts d -> records (map snd alts,d)
|
||||
Projection v l -> records v
|
||||
Selection v1 v2 -> records (v1,v2)
|
||||
_ -> S.empty
|
||||
|
||||
instance Records rhs => Records (TableRow rhs) where
|
||||
records (TableRow _ v) = records v
|
||||
|
||||
|
||||
-- | Record subtyping is converted into explicit coercions in Haskell
|
||||
coerce env ty t =
|
||||
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]]
|
||||
(RecordType rt,VarValue x)->
|
||||
case lookup x env of
|
||||
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
|
||||
--trace ("coerce "++render ty'++" to "++render ty) $
|
||||
app (to_rcon rt) [t]
|
||||
| otherwise -> t -- types match, no coercion needed
|
||||
_ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
|
||||
$$ "in" <+> map fst env))
|
||||
t
|
||||
_ -> t
|
||||
where
|
||||
app f ts = ParamConstant (Param f ts) -- !! a hack
|
||||
to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
|
||||
|
||||
patVars p = []
|
||||
|
||||
labels r = [l | RecordRow l _ <- r]
|
||||
aps f [] = f
|
||||
aps f (a:as) = aps (ap f a) as
|
||||
|
||||
proj = Var . identS . proj'
|
||||
proj' (LabelId l) = "proj_" ++ showRawIdent l
|
||||
proj' (LIdent l) = "proj_" ++ showRawIdent l
|
||||
rcon = Var . rcon'
|
||||
rcon' = identS . rcon_name
|
||||
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
|
||||
to_rcon' = ("to_"++) . rcon_name
|
||||
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LIdent l <- ls])
|
||||
|
||||
recordType ls =
|
||||
Data lhs [app] ["Eq","Ord","Show"]:
|
||||
enumAllInstance:
|
||||
zipWith projection vs ls ++
|
||||
[Eqn (identS (to_rcon' ls),[VarP r])
|
||||
(foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
|
||||
where
|
||||
r = identS "r"
|
||||
cn = rcon' ls
|
||||
-- Not all record labels are syntactically correct as type variables in Haskell
|
||||
-- app = cn<+>ls
|
||||
lhs = ConAp cn vs -- don't reuse record labels
|
||||
app = fmap TId lhs
|
||||
tapp = foldl TAp (TId cn) (map TId vs)
|
||||
vs = [identS ('t':show i)|i<-[1..n]]
|
||||
n = length ls
|
||||
|
||||
projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
|
||||
[((prj,[papp]),Var v)]
|
||||
where
|
||||
name = identS ("Has_"++render l)
|
||||
prj = identS (proj' l)
|
||||
papp = ConP cn (map VarP vs)
|
||||
|
||||
enumAllInstance =
|
||||
Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
|
||||
where
|
||||
ctx = [tEnumAll `TAp` TId v|v<-vs]
|
||||
tEnumAll = TId (identS "EnumAll")
|
||||
|
||||
labelClass l =
|
||||
Class [] (ConAp name [r,a]) [([r],[a])]
|
||||
[(identS (proj' l),TId r `Fun` TId a)]
|
||||
where
|
||||
name = identS ("Has_"++render l)
|
||||
r = identS "r"
|
||||
a = identS "a"
|
||||
|
||||
enumCon name arity =
|
||||
if arity==0
|
||||
then single (Var name)
|
||||
else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
|
||||
where
|
||||
ap (List [f]) a = Op f "<$>" a
|
||||
ap f a = Op f "<*>" a
|
||||
|
||||
lincatName,linfunName :: CatId -> Ident
|
||||
lincatName c = prefixIdent "Lin" (toIdent c)
|
||||
linfunName c = prefixIdent "lin" (toIdent c)
|
||||
|
||||
class ToIdent i where toIdent :: i -> Ident
|
||||
|
||||
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
|
||||
|
||||
qIdentC = identS . unqual
|
||||
|
||||
unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
|
||||
unqual (Unqual n) = showRawIdent n
|
||||
|
||||
instance ToIdent VarId where
|
||||
toIdent Anonymous = identW
|
||||
toIdent (VarId s) = identC s
|
||||
lincatName,linfunName :: Ident -> Ident
|
||||
lincatName c = prefixIdent "Lin" c
|
||||
linfunName c = prefixIdent "lin" c
|
||||
|
||||
@@ -2,422 +2,104 @@
|
||||
-- (a common intermediate representation to simplify export to other formats)
|
||||
module GF.Compile.GrammarToCanonical(
|
||||
grammar2canonical,abstract2canonical,concretes2canonical,
|
||||
projection,selection
|
||||
) 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 as G
|
||||
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
|
||||
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.Infra.Ident(ModuleName(..),Ident,identW,ident2raw,rawIdentS,showIdent)
|
||||
import GF.Infra.Option(Options,optionsPGF)
|
||||
import GF.Infra.CheckM
|
||||
import PGF2(Literal(..))
|
||||
import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef)
|
||||
import GF.Grammar.Canonical as C
|
||||
import System.FilePath ((</>), (<.>))
|
||||
import qualified Debug.Trace as T
|
||||
|
||||
import GF.Data.ErrM
|
||||
import GF.Grammar.Grammar
|
||||
import GF.Grammar.Lookup(allOrigInfos,lookupOrigInfo)
|
||||
import GF.Infra.Option(Options,noOptions)
|
||||
import GF.Infra.CheckM
|
||||
import GF.Compile.Compute.Concrete2
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Maybe(mapMaybe)
|
||||
import Control.Monad (forM)
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax and all associated
|
||||
-- concrete syntaxes
|
||||
grammar2canonical :: Options -> ModuleName -> G.Grammar -> Check C.Grammar
|
||||
grammar2canonical :: Options -> ModuleName -> Grammar -> Check Grammar
|
||||
grammar2canonical opts absname gr = do
|
||||
abs <- abstract2canonical absname gr
|
||||
cncs <- concretes2canonical opts absname gr
|
||||
return (Grammar abs (map snd cncs))
|
||||
return (mGrammar (abs:cncs))
|
||||
|
||||
-- | Generate Canonical code for the named abstract syntax
|
||||
abstract2canonical :: ModuleName -> G.Grammar -> Check Abstract
|
||||
abstract2canonical absname gr =
|
||||
return (Abstract (modId absname) (convFlags gr absname) cats funs)
|
||||
where
|
||||
cats = [CatDef (gId c) (convCtx ctx) | ((_,c),AbsCat ctx) <- adefs]
|
||||
|
||||
funs = [FunDef (gId f) (convType ty) |
|
||||
((_,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs]
|
||||
|
||||
adefs = allOrigInfos gr absname
|
||||
|
||||
convCtx = maybe [] (map convHypo . unLoc)
|
||||
convHypo (bt,name,t) =
|
||||
case typeForm t of
|
||||
([],(_,cat),[]) -> gId cat -- !!
|
||||
tf -> error ("abstract2canonical convHypo: " ++ show tf)
|
||||
|
||||
convType t =
|
||||
case typeForm t of
|
||||
(hyps,(_,cat),args) -> Type bs (TypeApp (gId cat) as)
|
||||
where
|
||||
bs = map convHypo' hyps
|
||||
as = map convType args
|
||||
|
||||
convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
|
||||
abstract2canonical :: ModuleName -> Grammar -> Check Module
|
||||
abstract2canonical absname gr = do
|
||||
let infos = [(id,info) | ((mn,id),info) <- allOrigInfos gr absname]
|
||||
return (absname, ModInfo {
|
||||
mtype = MTAbstract,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr absname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.fromList infos
|
||||
})
|
||||
|
||||
-- | Generate Canonical code for the all concrete syntaxes associated with
|
||||
-- the named abstract syntax in given the grammar.
|
||||
concretes2canonical :: Options -> ModuleName -> G.Grammar -> Check [(FilePath, Concrete)]
|
||||
concretes2canonical :: Options -> ModuleName -> Grammar -> Check [Module]
|
||||
concretes2canonical opts absname gr =
|
||||
sequence
|
||||
[fmap ((,) cncname) (concrete2canonical gr absname cnc cncmod)
|
||||
[concrete2canonical gr absname cnc modinfo
|
||||
| cnc<-allConcretes gr absname,
|
||||
let cncname = "canonical" </> render cnc <.> "gf"
|
||||
Ok cncmod = lookupModule gr cnc
|
||||
let Ok modinfo = lookupModule gr cnc
|
||||
]
|
||||
|
||||
-- | Generate Canonical GF for the given concrete module.
|
||||
concrete2canonical :: G.Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Concrete
|
||||
concrete2canonical gr absname cnc modinfo = do
|
||||
defs <- fmap concat $ mapM (toCanonical gr absname) (M.toList (jments modinfo))
|
||||
return (Concrete (modId cnc) (modId absname) (convFlags gr cnc)
|
||||
(neededParamTypes S.empty (params defs))
|
||||
[lincat | (_,Left lincat) <- defs]
|
||||
[lin | (_,Right lin) <- defs])
|
||||
concrete2canonical :: Grammar -> ModuleName -> ModuleName -> ModuleInfo -> Check Module
|
||||
concrete2canonical gr absname cncname modinfo = do
|
||||
let g = Gl gr (stdPredef g)
|
||||
infos <- mapM (convInfo g) (allOrigInfos gr cncname)
|
||||
let pts = Set.unions (map fst infos)
|
||||
pts <- closure pts (Set.toList pts)
|
||||
return (cncname, ModInfo {
|
||||
mtype = MTConcrete absname,
|
||||
mstatus = MSComplete,
|
||||
mflags = convFlags gr cncname,
|
||||
mextend = [],
|
||||
mwith = Nothing,
|
||||
mopens = [],
|
||||
mexdeps = [],
|
||||
msrc = "",
|
||||
mseqs = Nothing,
|
||||
jments = Map.union (Map.fromList (mapMaybe snd infos))
|
||||
pts
|
||||
})
|
||||
where
|
||||
params = S.toList . S.unions . map fst
|
||||
convInfo g ((mn,id), CncCat (Just (L loc typ)) lindef linref pprn mb_prods) = do
|
||||
typ <- normalForm g typ
|
||||
let pts = paramTypes typ
|
||||
return (pts,Just (id,CncCat (Just (L loc typ)) lindef linref pprn mb_prods))
|
||||
convInfo g ((mn,id), CncFun mb_ty@(Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn mb_prods) = do
|
||||
def <- normalForm g (eta_expand def ctx)
|
||||
return (Set.empty,Just (id,CncFun mb_ty (Just (L loc def)) pprn mb_prods))
|
||||
convInfo g _ = return (Set.empty,Nothing)
|
||||
|
||||
neededParamTypes have [] = []
|
||||
neededParamTypes have (q:qs) =
|
||||
if q `S.member` have
|
||||
then neededParamTypes have qs
|
||||
else let ((got,need),def) = paramType gr q
|
||||
in def++neededParamTypes (S.union got have) (S.toList need++qs)
|
||||
eta_expand t [] = t
|
||||
eta_expand t ((Implicit,x,_):ctx) = Abs Implicit x (eta_expand (App t (ImplArg (Vr x))) ctx)
|
||||
eta_expand t ((Explicit,x,_):ctx) = Abs Explicit x (eta_expand (App t (Vr x)) ctx)
|
||||
|
||||
-- toCanonical :: G.Grammar -> ModuleName -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
|
||||
toCanonical gr absname (name,jment) =
|
||||
case jment of
|
||||
CncCat (Just (L loc typ)) _ _ pprn _ -> do
|
||||
ntyp <- normalForm (Gl gr stdPredef) typ
|
||||
let pts = paramTypes gr ntyp
|
||||
return [(pts,Left (LincatDef (gId name) (convType ntyp)))]
|
||||
CncFun (Just r@(_,cat,ctx,lincat)) (Just (L loc def)) pprn _ -> do
|
||||
let params = [(b,x)|(b,x,_)<-ctx]
|
||||
args = map snd params
|
||||
e0 <- normalForm (Gl gr stdPredef) (mkAbs params (mkApp def (map Vr args)))
|
||||
let e = cleanupRecordFields lincat (unAbs (length params) e0)
|
||||
tts = tableTypes gr [e]
|
||||
return [(tts,Right (LinDef (gId name) (map gId args) (convert gr e)))]
|
||||
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
|
||||
Ok (m,jment) -> toCanonical gr absname (name,jment)
|
||||
_ -> return []
|
||||
_ -> return []
|
||||
where
|
||||
unAbs 0 t = t
|
||||
unAbs n (Abs _ _ t) = unAbs (n-1) t
|
||||
unAbs _ t = t
|
||||
paramTypes (RecType fs) = Set.unions (map (paramTypes.snd) fs)
|
||||
paramTypes (Table t1 t2) = Set.union (paramTypes t1) (paramTypes t2)
|
||||
paramTypes (App tf ta) = Set.union (paramTypes tf) (paramTypes ta)
|
||||
paramTypes (Sort _) = Set.empty
|
||||
paramTypes (EInt _) = Set.empty
|
||||
paramTypes (QC q) = Set.singleton q
|
||||
paramTypes (FV ts) = Set.unions (map paramTypes ts)
|
||||
paramTypes _ = Set.empty
|
||||
|
||||
tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
|
||||
tableTypes gr ts = S.unions (map tabtys ts)
|
||||
where
|
||||
tabtys t =
|
||||
case t of
|
||||
V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
|
||||
T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
|
||||
_ -> collectOp tabtys t
|
||||
closure pts [] = return Map.empty
|
||||
closure pts (q@(_,id):qs) = do
|
||||
(_,info@(ResParam (Just (L _ ps)) _)) <- lookupOrigInfo gr q
|
||||
let pts' = Set.unions [paramTypes ty | (_,ctx) <- ps, (_,_,ty) <- ctx]
|
||||
new_pts = Set.difference pts' pts
|
||||
infos <- closure (Set.union new_pts pts) (Set.toList new_pts++qs)
|
||||
return (Map.insert id info infos)
|
||||
|
||||
paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
|
||||
paramTypes gr t =
|
||||
case t of
|
||||
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
|
||||
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
|
||||
App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
|
||||
Sort _ -> S.empty
|
||||
EInt _ -> S.empty
|
||||
Q q -> lookup q
|
||||
QC q -> lookup q
|
||||
FV ts -> S.unions (map (paramTypes gr) ts)
|
||||
_ -> ignore
|
||||
where
|
||||
lookup q = case lookupOrigInfo gr q of
|
||||
Ok (_,ResOper _ (Just (L _ t))) ->
|
||||
S.insert q (paramTypes gr t)
|
||||
Ok (_,ResParam {}) -> S.singleton q
|
||||
_ -> ignore
|
||||
|
||||
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
|
||||
ppTv vs' = convert' gr vs'
|
||||
|
||||
ppT t =
|
||||
case t of
|
||||
-- Abs b x t -> ...
|
||||
-- V ty ts -> VTableValue (convType ty) (map ppT ts)
|
||||
V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
|
||||
where
|
||||
Ok pts = allParamValues gr ty
|
||||
Ok ps = mapM term2patt pts
|
||||
T (TTyped ty) cs -> TableValue (convType ty) (map ppCase cs)
|
||||
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 (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 (LInt 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 (LStr s)
|
||||
Empty -> LiteralValue (LStr "")
|
||||
FV ts -> VariantValue (map ppT ts)
|
||||
Alts t' vs -> alts vs (ppT t')
|
||||
_ -> error $ "convert' ppT: " ++ show t
|
||||
|
||||
ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
|
||||
|
||||
ppPredef n = error "TODO: ppPredef" {-
|
||||
case predef n of
|
||||
Ok BIND -> p "BIND"
|
||||
Ok SOFT_BIND -> p "SOFT_BIND"
|
||||
Ok SOFT_SPACE -> p "SOFT_SPACE"
|
||||
Ok CAPIT -> p "CAPIT"
|
||||
Ok ALL_CAPIT -> p "ALL_CAPIT"
|
||||
_ -> VarValue (gQId cPredef n) -- hmm
|
||||
where
|
||||
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))
|
||||
PR r -> RecordPattern (fields r) {-
|
||||
PW -> WildPattern
|
||||
PV x -> VarP x
|
||||
PString s -> Lit (show s) -- !!
|
||||
PInt i -> Lit (show i)
|
||||
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)
|
||||
|
||||
-- patToParam p = case ppP p of ParamPattern pv -> pv
|
||||
|
||||
-- token s = single (c "TK" `Ap` lit s)
|
||||
|
||||
alts vs = PreValue (map alt vs)
|
||||
where
|
||||
alt (t,p) = (pre p,ppT0 t)
|
||||
|
||||
pre (K s) = [s]
|
||||
pre Empty = [""] -- Empty == K ""
|
||||
pre (Strs ts) = concatMap pre ts
|
||||
pre (EPatt _ _ p) = pat p
|
||||
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 $ "convert' alts pat: "++show p
|
||||
|
||||
fields = map field . filter (not.isLockLabel.fst)
|
||||
field (l,(_,t)) = RecordRow (lblId l) (ppT t)
|
||||
--c = Const
|
||||
--c = VarValue . VarValueId
|
||||
--lit s = c (show s) -- hmm
|
||||
|
||||
ap f a = case f of
|
||||
ParamConstant (Param p ps) ->
|
||||
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 (LStr ""),_) -> v2
|
||||
(_,LiteralValue (LStr "")) -> v1
|
||||
_ -> ConcatValue v1 v2
|
||||
|
||||
-- | Smart constructor for projections
|
||||
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
|
||||
[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
|
||||
[rv] -> rv
|
||||
_ -> Selection (TableValue tt r') v
|
||||
where
|
||||
-- Don't introduce wildcard patterns, true to the canonical format,
|
||||
-- annotate (or eliminate) rhs in impossible rows
|
||||
r' = map trunc r
|
||||
trunc r@(TableRow p e) = if mightMatchRow v r
|
||||
then r
|
||||
else TableRow p (impossible e)
|
||||
{-
|
||||
-- Creates smaller tables, but introduces wildcard patterns
|
||||
r' = if null discard
|
||||
then r
|
||||
else keep++[TableRow WildPattern impossible]
|
||||
-}
|
||||
(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
|
||||
ParamConstant (Param c1 pvs) ->
|
||||
case p of
|
||||
ParamPattern (Param c2 pps) -> c1==c2 && length pvs==length pps &&
|
||||
and [mightMatch v p|(v,p)<-zip pvs pps]
|
||||
_ -> False
|
||||
RecordValue rv ->
|
||||
case p of
|
||||
RecordPattern 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 =
|
||||
case t of
|
||||
Table ti tv -> TableType (ppT ti) (ppT tv)
|
||||
RecType rt -> RecordType (convFields rt)
|
||||
-- App tf ta -> TAp (ppT tf) (ppT ta)
|
||||
-- FV [] -> tcon0 (identS "({-empty variant-})")
|
||||
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 $ "convType ppT: " ++ show t
|
||||
|
||||
convFields = map convField . filter (not.isLockLabel.fst)
|
||||
convField (l,r) = RecordRow (lblId l) (ppT r)
|
||||
|
||||
convSort k = case showIdent k of
|
||||
"Float" -> FloatType
|
||||
"Int" -> IntType
|
||||
"Str" -> StrType
|
||||
_ -> error $ "convType convSort: " ++ show k
|
||||
|
||||
toParamType :: Term -> ParamType
|
||||
toParamType t = case convType t of
|
||||
ParamType pt -> pt
|
||||
_ -> 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)) _)
|
||||
{- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
|
||||
((S.singleton (m,n),argTypes ps),
|
||||
[ParamDef name (map (param m) ps)]
|
||||
)
|
||||
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 ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
|
||||
| otherwise ->
|
||||
((S.singleton (m,n),paramTypes gr t),
|
||||
[ParamAliasDef (gQId m n) (convType t)])
|
||||
_ -> ((S.empty,S.empty),[])
|
||||
where
|
||||
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 :: 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 i == identW then Anonymous else VarId (ident2raw i)
|
||||
|
||||
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
|
||||
|
||||
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
|
||||
instance QualIdent VarValueId where gQId m n = VarValueId (qual m 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 [(rawIdentS n,v) |
|
||||
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
|
||||
convFlags :: Grammar -> ModuleName -> Options
|
||||
convFlags gr mn = err (const noOptions) mflags (lookupModule gr mn)
|
||||
|
||||
@@ -39,7 +39,6 @@ grammar2haskell opts name gr = foldr (++++) [] $
|
||||
where gr' = hSkeleton gr
|
||||
gadt = haskellOption opts HaskellGADT
|
||||
dataExt = haskellOption opts HaskellData
|
||||
pgf2 = haskellOption opts HaskellPGF2
|
||||
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
|
||||
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
|
||||
| otherwise = ("G"++) . rmForbiddenChars
|
||||
@@ -54,8 +53,7 @@ grammar2haskell opts name gr = foldr (++++) [] $
|
||||
extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
|
||||
| dataExt = ["import Data.Data"]
|
||||
| otherwise = []
|
||||
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
|
||||
| otherwise = ["import PGF hiding (Tree)"]
|
||||
pgfImports = ["import PGF2", ""]
|
||||
types | gadt = datatypesGADT gId lexical gr'
|
||||
| otherwise = datatypes gId derivingClause lexical gr'
|
||||
compos | gadt = prCompos gId lexical gr' ++ composClass
|
||||
@@ -78,7 +76,7 @@ haskPreamble gadt name derivingClause imports =
|
||||
"",
|
||||
predefInst gadt derivingClause "GString" "String" "unStr" "mkStr",
|
||||
"",
|
||||
predefInst gadt derivingClause "GInt" "Int" "unInt" "mkInt",
|
||||
predefInst gadt derivingClause "GInt" "Integer" "unInt" "mkInt",
|
||||
"",
|
||||
predefInst gadt derivingClause "GFloat" "Double" "unFloat" "mkFloat",
|
||||
"",
|
||||
@@ -234,14 +232,14 @@ hInstance gId lexical m (cat,rules)
|
||||
| otherwise =
|
||||
"instance Gf" +++ gId cat +++ "where\n" ++
|
||||
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
|
||||
++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp (mkCId x) []"] else [])
|
||||
++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = mkApp x []"] else [])
|
||||
where
|
||||
ec = elemCat cat
|
||||
baseVars = mkVars (baseSize (cat,rules))
|
||||
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
|
||||
(if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
|
||||
"=" +++ mkRHS f xx'
|
||||
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
|
||||
mkRHS f vars = "mkApp \"" ++ f ++ "\"" +++
|
||||
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
|
||||
|
||||
mkVars :: Int -> [String]
|
||||
@@ -265,7 +263,7 @@ fInstance gId lexical m (cat,rules) =
|
||||
mkInst f xx =
|
||||
" Just (i," ++
|
||||
"[" ++ prTList "," xx' ++ "])" +++
|
||||
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
|
||||
"| i == \"" ++ f ++ "\" ->" +++ mkRHS f xx'
|
||||
where
|
||||
xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
|
||||
mkRHS f vars
|
||||
|
||||
@@ -6,11 +6,13 @@ import GF.Compile as S(batchCompile,link,srcAbsName)
|
||||
import GF.CompileInParallel as P(parallelBatchCompile)
|
||||
import GF.Compile.Export
|
||||
import GF.Compile.ConcreteToHaskell(concretes2haskell)
|
||||
import GF.Compile.GrammarToCanonical--(concretes2canonical)
|
||||
import GF.Compile.GrammarToCanonical
|
||||
import GF.Compile.CFGtoPGF
|
||||
import GF.Compile.GetGrammar
|
||||
import GF.Grammar.BNFC
|
||||
import GF.Grammar.CFG
|
||||
import GF.Grammar.JSON(grammar2json)
|
||||
import GF.Grammar.Printer(TermPrintQual(..),ppModule)
|
||||
|
||||
--import GF.Infra.Ident(showIdent)
|
||||
import GF.Infra.UseIO
|
||||
@@ -24,7 +26,7 @@ import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import GF.Grammar.CanonicalJSON (encodeJSON)
|
||||
import Text.JSON (encode)
|
||||
import System.FilePath
|
||||
import Control.Monad(when,unless,forM_,foldM)
|
||||
|
||||
@@ -64,7 +66,7 @@ compileSourceFiles opts fs =
|
||||
do createDirectoryIfMissing False "canonical"
|
||||
mapM_ abs2canonical canonical
|
||||
mapM_ cnc2canonical canonical
|
||||
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2json canonical
|
||||
when (FmtCanonicalJson `elem` ofmts) $ mapM_ grammar2canonical_json canonical
|
||||
where
|
||||
ofmts = flag optOutputFormats opts
|
||||
|
||||
@@ -74,17 +76,17 @@ compileSourceFiles opts fs =
|
||||
|
||||
abs2canonical (cnc,gr) = do
|
||||
(canAbs,_) <- runCheck (abstract2canonical absname gr)
|
||||
writeExport ("canonical/"++render absname++".gf",render80 canAbs)
|
||||
writeExport ("canonical/"++render absname++".gf",render80 (ppModule Unqualified canAbs))
|
||||
where
|
||||
absname = srcAbsName gr cnc
|
||||
|
||||
cnc2canonical (cnc,gr) = do
|
||||
(res,_) <- runCheck (concretes2canonical opts (srcAbsName gr cnc) gr)
|
||||
mapM_ (writeExport.fmap render80) res
|
||||
sequence_ [writeExport ("canonical/"++render mn++".gf",render80 (ppModule Unqualified m)) | m@(mn,mi) <- res]
|
||||
|
||||
grammar2json (cnc,gr) = do
|
||||
grammar2canonical_json (cnc,gr) = do
|
||||
(gr_canon,_) <- runCheck (grammar2canonical opts absname gr)
|
||||
return (encodeJSON (render absname ++ ".json") gr_canon)
|
||||
writeExport (render absname ++ ".json", encode (grammar2json Unqualified gr_canon))
|
||||
where
|
||||
absname = srcAbsName gr cnc
|
||||
|
||||
|
||||
@@ -1,304 +0,0 @@
|
||||
-- |
|
||||
-- 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.
|
||||
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
module GF.Grammar.Canonical where
|
||||
|
||||
import Prelude hiding ((<>))
|
||||
import GF.Text.Pretty
|
||||
import GF.Infra.Ident (RawIdent)
|
||||
import PGF(Literal(..))
|
||||
|
||||
-- | A Complete grammar
|
||||
data Grammar = Grammar Abstract [Concrete] deriving Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
|
||||
-- | Abstract Syntax
|
||||
data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
|
||||
abstrName (Abstract mn _ _ _) = mn
|
||||
|
||||
data CatDef = CatDef CatId [CatId] deriving Show
|
||||
data FunDef = FunDef FunId Type deriving Show
|
||||
data Type = Type [TypeBinding] TypeApp deriving Show
|
||||
data TypeApp = TypeApp CatId [Type] deriving Show
|
||||
|
||||
data TypeBinding = TypeBinding VarId Type deriving Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Concreate syntax
|
||||
|
||||
-- | Concrete Syntax
|
||||
data Concrete = Concrete ModId ModId Flags [ParamDef] [LincatDef] [LinDef]
|
||||
deriving Show
|
||||
concName (Concrete cnc _ _ _ _ _) = cnc
|
||||
|
||||
data ParamDef = ParamDef ParamId [ParamValueDef]
|
||||
| ParamAliasDef ParamId LinType
|
||||
deriving Show
|
||||
data LincatDef = LincatDef CatId LinType deriving Show
|
||||
data LinDef = LinDef FunId [VarId] LinValue deriving Show
|
||||
|
||||
-- | Linearization type, RHS of @lincat@
|
||||
data LinType = FloatType
|
||||
| IntType
|
||||
| ParamType ParamType
|
||||
| RecordType [RecordRowType]
|
||||
| StrType
|
||||
| TableType LinType LinType
|
||||
| TupleType [LinType]
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
|
||||
|
||||
-- | Linearization value, RHS of @lin@
|
||||
data LinValue = ConcatValue LinValue LinValue
|
||||
| LiteralValue Literal
|
||||
| ErrorValue String
|
||||
| ParamConstant ParamValue
|
||||
| PredefValue PredefId
|
||||
| RecordValue [RecordRowValue]
|
||||
| TableValue LinType [TableRowValue]
|
||||
--- | VTableValue LinType [LinValue]
|
||||
| TupleValue [LinValue]
|
||||
| VariantValue [LinValue]
|
||||
| VarValue VarValueId
|
||||
| PreValue [([String], LinValue)] LinValue
|
||||
| Projection LinValue LabelId
|
||||
| Selection LinValue LinValue
|
||||
| CommentedValue String LinValue
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data LinPattern = ParamPattern ParamPattern
|
||||
| RecordPattern [RecordRow LinPattern]
|
||||
| TuplePattern [LinPattern]
|
||||
| WildPattern
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
type ParamValue = Param LinValue
|
||||
type ParamPattern = Param LinPattern
|
||||
type ParamValueDef = Param ParamId
|
||||
|
||||
data Param arg = Param ParamId [arg]
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
|
||||
type RecordRowType = RecordRow LinType
|
||||
type RecordRowValue = RecordRow LinValue
|
||||
type TableRowValue = TableRow LinValue
|
||||
|
||||
data RecordRow rhs = RecordRow LabelId rhs
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
data TableRow rhs = TableRow LinPattern rhs
|
||||
deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
|
||||
|
||||
-- *** Identifiers in Concrete Syntax
|
||||
|
||||
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 QualId deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Used in both Abstract and Concrete Syntax
|
||||
|
||||
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
|
||||
|
||||
newtype Flags = Flags [(FlagName,Literal)] deriving Show
|
||||
type FlagName = Id
|
||||
|
||||
|
||||
-- *** Identifiers
|
||||
|
||||
type Id = RawIdent
|
||||
data QualId = Qual ModId Id | Unqual Id deriving (Eq,Ord,Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Pretty printing
|
||||
|
||||
instance Pretty Grammar where
|
||||
pp (Grammar abs cncs) = abs $+$ vcat cncs
|
||||
|
||||
instance Pretty Abstract where
|
||||
pp (Abstract m flags cats funs) =
|
||||
"abstract" <+> m <+> "=" <+> "{" $$
|
||||
flags $$
|
||||
"cat" <+> fsep cats $$
|
||||
"fun" <+> vcat funs $$
|
||||
"}"
|
||||
|
||||
instance Pretty CatDef where
|
||||
pp (CatDef c cs) = hsep (c:cs)<>";"
|
||||
|
||||
instance Pretty FunDef where
|
||||
pp (FunDef f ty) = f <+> ":" <+> ty <>";"
|
||||
|
||||
instance Pretty Type where
|
||||
pp (Type bs ty) = sep (punctuate " ->" (map pp bs ++ [pp ty]))
|
||||
|
||||
instance PPA Type where
|
||||
ppA (Type [] (TypeApp c [])) = pp c
|
||||
ppA t = parens t
|
||||
|
||||
instance Pretty TypeBinding where
|
||||
pp (TypeBinding Anonymous (Type [] tapp)) = pp tapp
|
||||
pp (TypeBinding Anonymous ty) = parens ty
|
||||
pp (TypeBinding (VarId x) ty) = parens (x<+>":"<+>ty)
|
||||
|
||||
instance Pretty TypeApp where
|
||||
pp (TypeApp c targs) = c<+>hsep (map ppA targs)
|
||||
|
||||
instance Pretty VarId where
|
||||
pp Anonymous = pp "_"
|
||||
pp (VarId x) = pp x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
instance Pretty Concrete where
|
||||
pp (Concrete cncid absid flags params lincats lins) =
|
||||
"concrete" <+> cncid <+> "of" <+> absid <+> "=" <+> "{" $$
|
||||
vcat params $$
|
||||
section "lincat" lincats $$
|
||||
section "lin" lins $$
|
||||
"}"
|
||||
where
|
||||
section name [] = empty
|
||||
section name ds = name <+> vcat (map (<> ";") ds)
|
||||
|
||||
instance Pretty ParamDef where
|
||||
pp (ParamDef p pvs) = hang ("param"<+> p <+> "=") 4 (punctuate " |" pvs)<>";"
|
||||
pp (ParamAliasDef p t) = hang ("oper"<+> p <+> "=") 4 t<>";"
|
||||
|
||||
instance PPA arg => Pretty (Param arg) where
|
||||
pp (Param p ps) = pp p<+>sep (map ppA ps)
|
||||
|
||||
instance PPA arg => PPA (Param arg) where
|
||||
ppA (Param p []) = pp p
|
||||
ppA pv = parens pv
|
||||
|
||||
instance Pretty LincatDef where
|
||||
pp (LincatDef c lt) = hang (c <+> "=") 4 lt
|
||||
|
||||
instance Pretty LinType where
|
||||
pp lt = case lt of
|
||||
FloatType -> pp "Float"
|
||||
IntType -> pp "Int"
|
||||
ParamType pt -> pp pt
|
||||
RecordType rs -> block rs
|
||||
StrType -> pp "Str"
|
||||
TableType pt lt -> sep [pt <+> "=>",pp lt]
|
||||
TupleType lts -> "<"<>punctuate "," lts<>">"
|
||||
|
||||
instance RhsSeparator LinType where rhsSep _ = pp ":"
|
||||
|
||||
instance Pretty ParamType where
|
||||
pp (ParamTypeId p) = pp p
|
||||
|
||||
instance Pretty LinDef where
|
||||
pp (LinDef f xs lv) = hang (f<+>hsep xs<+>"=") 4 lv
|
||||
|
||||
instance Pretty LinValue where
|
||||
pp lv = case lv of
|
||||
ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
|
||||
ErrorValue s -> "Predef.error"<+>doubleQuotes s
|
||||
ParamConstant pv -> pp pv
|
||||
Projection lv l -> ppA lv<>"."<>l
|
||||
Selection tv pv -> ppA tv<>"!"<>ppA pv
|
||||
VariantValue vs -> "variants"<+>block vs
|
||||
CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
|
||||
_ -> ppA lv
|
||||
|
||||
instance PPA LinValue where
|
||||
ppA lv = case lv of
|
||||
LiteralValue l -> ppA l
|
||||
ParamConstant pv -> ppA pv
|
||||
PredefValue p -> ppA p
|
||||
RecordValue [] -> pp "<>"
|
||||
RecordValue rvs -> block rvs
|
||||
PreValue alts def ->
|
||||
"pre"<+>block (map alt alts++["_"<+>"=>"<+>def])
|
||||
where
|
||||
alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
|
||||
2 ("=>"<+>lv)
|
||||
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 Literal where pp = ppA
|
||||
|
||||
instance PPA Literal where
|
||||
ppA l = case l of
|
||||
LFlt f -> pp f
|
||||
LInt n -> pp n
|
||||
LStr s -> doubleQuotes s -- hmm
|
||||
|
||||
instance RhsSeparator LinValue where rhsSep _ = pp "="
|
||||
|
||||
instance Pretty LinPattern where
|
||||
pp p =
|
||||
case p of
|
||||
ParamPattern pv -> pp pv
|
||||
_ -> ppA p
|
||||
|
||||
instance PPA LinPattern where
|
||||
ppA p =
|
||||
case p of
|
||||
ParamPattern pv -> ppA pv
|
||||
RecordPattern r -> block r
|
||||
TuplePattern ps -> "<"<>punctuate "," ps<>">"
|
||||
WildPattern -> pp "_"
|
||||
|
||||
instance RhsSeparator LinPattern where rhsSep _ = pp "="
|
||||
|
||||
instance RhsSeparator rhs => Pretty (RecordRow rhs) where
|
||||
pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
|
||||
|
||||
instance Pretty rhs => Pretty (TableRow rhs) where
|
||||
pp (TableRow l v) = hang (l<+>"=>") 2 v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
instance Pretty ModId where pp (ModId s) = pp s
|
||||
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) = "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)
|
||||
where
|
||||
ppFlag (name,value) = name <+> "=" <+> value <>";"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
|
||||
class Pretty a => PPA a where ppA :: a -> Doc
|
||||
|
||||
class Pretty rhs => RhsSeparator rhs where rhsSep :: rhs -> Doc
|
||||
|
||||
semiSep xs = punctuate ";" xs
|
||||
block xs = braces (semiSep xs)
|
||||
@@ -1,289 +0,0 @@
|
||||
module GF.Grammar.CanonicalJSON (
|
||||
encodeJSON
|
||||
) where
|
||||
|
||||
import Text.JSON
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Ratio (denominator, numerator)
|
||||
import GF.Grammar.Canonical
|
||||
import Control.Monad (guard)
|
||||
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
|
||||
import PGF(Literal(..))
|
||||
|
||||
encodeJSON :: FilePath -> Grammar -> IO ()
|
||||
encodeJSON fpath g = writeFile fpath (encode g)
|
||||
|
||||
|
||||
-- in general we encode grammars using JSON objects/records,
|
||||
-- except for newtypes/coercions/direct values
|
||||
|
||||
-- the top-level definitions use normal record labels,
|
||||
-- but recursive types/values/ids use labels staring with a "."
|
||||
|
||||
instance JSON Grammar where
|
||||
showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
|
||||
|
||||
readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Abstract Syntax
|
||||
|
||||
instance JSON Abstract where
|
||||
showJSON (Abstract absid flags cats funs)
|
||||
= makeObj [("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("cats", showJSON cats),
|
||||
("funs", showJSON funs)]
|
||||
|
||||
readJSON o = Abstract
|
||||
<$> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"cats"
|
||||
<*> o!"funs"
|
||||
|
||||
instance JSON CatDef where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (CatDef c []) = showJSON c
|
||||
showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
|
||||
|
||||
readJSON o = CatDef <$> readJSON o <*> return []
|
||||
<|> CatDef <$> o!"cat" <*> o!"args"
|
||||
|
||||
instance JSON FunDef where
|
||||
showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
|
||||
|
||||
readJSON o = FunDef <$> o!"fun" <*> o!"type"
|
||||
|
||||
instance JSON Type where
|
||||
showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
|
||||
|
||||
readJSON o = Type <$> o!".args" <*> o!".result"
|
||||
|
||||
instance JSON TypeApp where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeApp c []) = showJSON c
|
||||
showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
|
||||
|
||||
readJSON o = TypeApp <$> readJSON o <*> return []
|
||||
<|> TypeApp <$> o!".cat" <*> o!".args"
|
||||
|
||||
instance JSON TypeBinding where
|
||||
-- non-dependent categories are encoded as simple strings:
|
||||
showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
|
||||
showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
|
||||
|
||||
readJSON o = do c <- readJSON o
|
||||
return (TypeBinding Anonymous (Type [] (TypeApp c [])))
|
||||
<|> TypeBinding <$> o!".var" <*> o!".type"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Concrete syntax
|
||||
|
||||
instance JSON Concrete where
|
||||
showJSON (Concrete cncid absid flags params lincats lins)
|
||||
= makeObj [("cnc", showJSON cncid),
|
||||
("abs", showJSON absid),
|
||||
("flags", showJSON flags),
|
||||
("params", showJSON params),
|
||||
("lincats", showJSON lincats),
|
||||
("lins", showJSON lins)]
|
||||
|
||||
readJSON o = Concrete
|
||||
<$> o!"cnc"
|
||||
<*> o!"abs"
|
||||
<*>(o!"flags" <|> return (Flags []))
|
||||
<*> o!"params"
|
||||
<*> o!"lincats"
|
||||
<*> o!"lins"
|
||||
|
||||
instance JSON ParamDef where
|
||||
showJSON (ParamDef p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
|
||||
showJSON (ParamAliasDef p t) = makeObj [("param", showJSON p), ("alias", showJSON t)]
|
||||
|
||||
readJSON o = ParamDef <$> o!"param" <*> o!"values"
|
||||
<|> ParamAliasDef <$> o!"param" <*> o!"alias"
|
||||
|
||||
instance JSON LincatDef where
|
||||
showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
|
||||
|
||||
readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
|
||||
|
||||
instance JSON LinDef where
|
||||
showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
|
||||
|
||||
readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
|
||||
|
||||
instance JSON LinType where
|
||||
-- the basic types (Str, Float, Int) are encoded as strings:
|
||||
showJSON (StrType) = showJSON "Str"
|
||||
showJSON (FloatType) = showJSON "Float"
|
||||
showJSON (IntType) = showJSON "Int"
|
||||
-- parameters are also encoded as strings:
|
||||
showJSON (ParamType pt) = showJSON pt
|
||||
-- tables/tuples are encoded as JSON objects:
|
||||
showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
|
||||
showJSON (TupleType lts) = makeObj [(".tuple", showJSON lts)]
|
||||
-- records are encoded as records:
|
||||
showJSON (RecordType rows) = showJSON rows
|
||||
|
||||
readJSON o = StrType <$ parseString "Str" o
|
||||
<|> FloatType <$ parseString "Float" o
|
||||
<|> IntType <$ parseString "Int" o
|
||||
<|> ParamType <$> readJSON o
|
||||
<|> TableType <$> o!".tblarg" <*> o!".tblval"
|
||||
<|> TupleType <$> o!".tuple"
|
||||
<|> RecordType <$> readJSON o
|
||||
|
||||
instance JSON LinValue where
|
||||
showJSON (LiteralValue l ) = showJSON l
|
||||
-- most values are encoded as JSON objects:
|
||||
showJSON (ParamConstant pv) = makeObj [(".param", showJSON pv)]
|
||||
showJSON (PredefValue p ) = makeObj [(".predef", showJSON p)]
|
||||
showJSON (TableValue t tvs) = makeObj [(".tblarg", showJSON t), (".tblrows", showJSON tvs)]
|
||||
showJSON (TupleValue lvs) = makeObj [(".tuple", showJSON lvs)]
|
||||
showJSON (VarValue v ) = makeObj [(".var", showJSON v)]
|
||||
showJSON (ErrorValue s ) = makeObj [(".error", showJSON s)]
|
||||
showJSON (Projection lv l ) = makeObj [(".project", showJSON lv), (".label", showJSON l)]
|
||||
showJSON (Selection tv pv) = makeObj [(".select", showJSON tv), (".key", showJSON pv)]
|
||||
showJSON (VariantValue vs) = makeObj [(".variants", showJSON vs)]
|
||||
showJSON (PreValue pre def) = makeObj [(".pre", showJSON pre),(".default", showJSON def)]
|
||||
-- records are encoded directly as JSON records:
|
||||
showJSON (RecordValue rows) = showJSON rows
|
||||
-- concatenation is encoded as a JSON array:
|
||||
showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
|
||||
where flatten (ConcatValue v v') = flatten v . flatten v'
|
||||
flatten v = (v :)
|
||||
|
||||
readJSON o = LiteralValue <$> readJSON o
|
||||
<|> ParamConstant <$> o!".param"
|
||||
<|> PredefValue <$> o!".predef"
|
||||
<|> TableValue <$> o!".tblarg" <*> o!".tblrows"
|
||||
<|> TupleValue <$> o!".tuple"
|
||||
<|> VarValue <$> o!".var"
|
||||
<|> ErrorValue <$> o!".error"
|
||||
<|> Projection <$> o!".project" <*> o!".label"
|
||||
<|> Selection <$> o!".select" <*> o!".key"
|
||||
<|> VariantValue <$> o!".variants"
|
||||
<|> PreValue <$> o!".pre" <*> o!".default"
|
||||
<|> RecordValue <$> readJSON o
|
||||
<|> do vs <- readJSON o :: Result [LinValue]
|
||||
return (foldr1 ConcatValue vs)
|
||||
|
||||
instance JSON Literal where
|
||||
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
|
||||
showJSON (LStr s) = showJSON s
|
||||
showJSON (LFlt f) = showJSON f
|
||||
showJSON (LInt n) = showJSON n
|
||||
|
||||
readJSON = readBasicJSON LStr LInt LFlt
|
||||
|
||||
instance JSON LinPattern where
|
||||
-- wildcards and patterns without arguments are encoded as strings:
|
||||
showJSON (WildPattern) = showJSON "_"
|
||||
showJSON (ParamPattern (Param p [])) = showJSON p
|
||||
-- complex patterns are encoded as JSON objects:
|
||||
showJSON (ParamPattern pv) = showJSON pv
|
||||
-- and records as records:
|
||||
showJSON (RecordPattern r) = showJSON r
|
||||
|
||||
readJSON o = do p <- parseString "_" o; return WildPattern
|
||||
<|> do p <- readJSON o; return (ParamPattern (Param p []))
|
||||
<|> ParamPattern <$> readJSON o
|
||||
<|> RecordPattern <$> readJSON o
|
||||
|
||||
instance JSON arg => JSON (Param arg) where
|
||||
-- parameters without arguments are encoded as strings:
|
||||
showJSON (Param p []) = showJSON p
|
||||
showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
|
||||
|
||||
readJSON o = Param <$> readJSON o <*> return []
|
||||
<|> Param <$> o!".paramid" <*> o!".args"
|
||||
|
||||
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) = (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 (rawIdentS lbl)) value)
|
||||
|
||||
instance JSON rhs => JSON (TableRow rhs) where
|
||||
showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
|
||||
|
||||
readJSON o = TableRow <$> o!".pattern" <*> o!".value"
|
||||
|
||||
|
||||
-- *** 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
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** 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 VarId where
|
||||
-- the anonymous variable is the underscore:
|
||||
showJSON Anonymous = showJSON "_"
|
||||
showJSON (VarId x) = showJSON x
|
||||
|
||||
readJSON o = do parseString "_" o; return Anonymous
|
||||
<|> VarId <$> readJSON o
|
||||
|
||||
instance JSON QualId where
|
||||
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 (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 [(showRawIdent f, showJSON v) | (f, v) <- fs]
|
||||
|
||||
readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
|
||||
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
|
||||
return (rawIdentS lbl, value)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- ** Convenience functions
|
||||
|
||||
parseString :: String -> JSValue -> Result ()
|
||||
parseString s o = guard . (== s) =<< readJSON o
|
||||
|
||||
(!) :: JSON a => JSValue -> String -> Result a
|
||||
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
|
||||
readJSON
|
||||
(lookup key (assocsJSObject obj))
|
||||
|
||||
assocsJSObject :: JSValue -> [(String, JSValue)]
|
||||
assocsJSObject (JSObject o) = fromJSObject o
|
||||
assocsJSObject (JSArray _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
|
||||
assocsJSObject jsvalue = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
|
||||
|
||||
|
||||
readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
|
||||
(String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
|
||||
readBasicJSON str int flt o
|
||||
= str <$> readJSON o
|
||||
<|> int_or_flt <$> readJSON o
|
||||
where int_or_flt f | f == fromIntegral n = int n
|
||||
| otherwise = flt f
|
||||
where n = round f
|
||||
@@ -31,6 +31,7 @@ import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
|
||||
-- UTF-8-encoded bytestrings!
|
||||
import Data.Char(isDigit)
|
||||
import Data.Binary(Binary(..))
|
||||
import Text.JSON hiding (Result(..))
|
||||
import GF.Text.Pretty
|
||||
|
||||
|
||||
@@ -46,6 +47,10 @@ instance Binary ModuleName where
|
||||
put (MN id) = put id
|
||||
get = fmap MN get
|
||||
|
||||
instance JSON ModuleName where
|
||||
showJSON (MN id) = showJSON id
|
||||
readJSON o = MN <$> readJSON o
|
||||
|
||||
-- | the constructors labelled /INTERNAL/ are
|
||||
-- internal representation never returned by the parser
|
||||
data Ident =
|
||||
@@ -101,6 +106,14 @@ instance Pretty Ident where pp = pp . showIdent
|
||||
|
||||
instance Pretty RawIdent where pp = pp . showRawIdent
|
||||
|
||||
instance JSON Ident where
|
||||
showJSON i = showJSON $ ident2raw i
|
||||
readJSON o = identC <$> readJSON o
|
||||
|
||||
instance JSON RawIdent where
|
||||
showJSON i = showJSON $ showRawIdent i
|
||||
readJSON o = rawIdentS <$> readJSON o
|
||||
|
||||
identS :: String -> Ident
|
||||
identS = identC . rawIdentS
|
||||
|
||||
|
||||
@@ -134,7 +134,6 @@ data HaskellOption = HaskellNoPrefix
|
||||
| HaskellConcrete
|
||||
| HaskellVariants
|
||||
| HaskellData
|
||||
| HaskellPGF2
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Warning = WarnMissingLincat
|
||||
@@ -530,8 +529,7 @@ haskellOptionNames =
|
||||
("lexical", HaskellLexical),
|
||||
("concrete", HaskellConcrete),
|
||||
("variants", HaskellVariants),
|
||||
("data", HaskellData),
|
||||
("pgf2", HaskellPGF2)]
|
||||
("data", HaskellData)]
|
||||
|
||||
-- | This is for bacward compatibility. Since GHC 6.12 we
|
||||
-- started using the native Unicode support in GHC but it
|
||||
|
||||
@@ -87,7 +87,6 @@ library
|
||||
GF.Support
|
||||
GF.Text.Pretty
|
||||
GF.Text.Lexing
|
||||
GF.Grammar.Canonical
|
||||
|
||||
GF.CompileOne GF.Compile.GetGrammar
|
||||
|
||||
@@ -120,7 +119,6 @@ library
|
||||
GF.Haskell
|
||||
GF.Compile.ConcreteToHaskell
|
||||
GF.Compile.GrammarToCanonical
|
||||
GF.Grammar.CanonicalJSON
|
||||
GF.Compile.ReadFiles
|
||||
GF.Compile.Rename
|
||||
GF.Compile.Repl
|
||||
@@ -156,6 +154,7 @@ library
|
||||
GF.Grammar.ShowTerm
|
||||
GF.Grammar.Unify
|
||||
GF.Grammar.Values
|
||||
GF.Grammar.JSON
|
||||
GF.Infra.Concurrency
|
||||
GF.Infra.Dependencies
|
||||
GF.Infra.GetOpt
|
||||
|
||||
Reference in New Issue
Block a user