diff --git a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs index 849c9d9a1..03da6ac83 100644 --- a/src/compiler/api/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/api/GF/Compile/ConcreteToHaskell.hs @@ -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 diff --git a/src/compiler/api/GF/Compile/GrammarToCanonical.hs b/src/compiler/api/GF/Compile/GrammarToCanonical.hs index b7a1d5db6..4b2e56c50 100644 --- a/src/compiler/api/GF/Compile/GrammarToCanonical.hs +++ b/src/compiler/api/GF/Compile/GrammarToCanonical.hs @@ -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) diff --git a/src/compiler/api/GF/Compile/PGFtoHaskell.hs b/src/compiler/api/GF/Compile/PGFtoHaskell.hs index b69f8bc4a..c5704e737 100644 --- a/src/compiler/api/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/api/GF/Compile/PGFtoHaskell.hs @@ -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 diff --git a/src/compiler/api/GF/Compiler.hs b/src/compiler/api/GF/Compiler.hs index 4076a0e70..7bc387f13 100644 --- a/src/compiler/api/GF/Compiler.hs +++ b/src/compiler/api/GF/Compiler.hs @@ -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 diff --git a/src/compiler/api/GF/Grammar/Canonical.hs b/src/compiler/api/GF/Grammar/Canonical.hs deleted file mode 100644 index cc581f826..000000000 --- a/src/compiler/api/GF/Grammar/Canonical.hs +++ /dev/null @@ -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) diff --git a/src/compiler/api/GF/Grammar/CanonicalJSON.hs b/src/compiler/api/GF/Grammar/CanonicalJSON.hs deleted file mode 100644 index 5c2457350..000000000 --- a/src/compiler/api/GF/Grammar/CanonicalJSON.hs +++ /dev/null @@ -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 diff --git a/src/compiler/api/GF/Infra/Ident.hs b/src/compiler/api/GF/Infra/Ident.hs index dac127434..e202512f4 100644 --- a/src/compiler/api/GF/Infra/Ident.hs +++ b/src/compiler/api/GF/Infra/Ident.hs @@ -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 diff --git a/src/compiler/api/GF/Infra/Option.hs b/src/compiler/api/GF/Infra/Option.hs index 61a5e80a3..30e27720d 100644 --- a/src/compiler/api/GF/Infra/Option.hs +++ b/src/compiler/api/GF/Infra/Option.hs @@ -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 diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index fa0d34358..e0dc76ccb 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -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