diff --git a/gf.cabal b/gf.cabal index acd169aaf..898968a48 100644 --- a/gf.cabal +++ b/gf.cabal @@ -186,9 +186,12 @@ Library GF.Compile.Multi GF.Compile.Optimize GF.Compile.PGFtoHaskell + GF.Compile.PGFtoAbstract GF.Compile.PGFtoJava GF.Haskell GF.Compile.ConcreteToHaskell + GF.Compile.ConcreteToCanonical + GF.Grammar.Canonical GF.Compile.PGFtoJS GF.Compile.PGFtoProlog GF.Compile.PGFtoPython diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs new file mode 100644 index 000000000..5208fd005 --- /dev/null +++ b/src/compiler/GF/Compile/ConcreteToCanonical.hs @@ -0,0 +1,404 @@ +-- | Translate concrete syntax to canonical form +module GF.Compile.ConcreteToCanonical(concretes2canonical) where +import Data.List(nub,sort,sortBy,partition) +--import Data.Function(on) +import qualified Data.Map as M +import qualified Data.Set as S +import GF.Data.ErrM +import GF.Data.Utilities(mapSnd) +import GF.Text.Pretty +import GF.Grammar.Grammar +import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos,allParamValues) +import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt) +import GF.Grammar.Lockfield(isLockLabel) +import GF.Grammar.Predef(cPredef,cInts) +import GF.Compile.Compute.Predef(predef) +import GF.Compile.Compute.Value(Predefined(..)) +import GF.Infra.Ident(ModuleName(..),Ident,identS,prefixIdent,showIdent,isWildIdent) --,moduleNameS +--import GF.Infra.Option +import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) +import GF.Grammar.Canonical as C +import Debug.Trace + +-- | Generate Canonical code for the all concrete syntaxes associated with +-- the named abstract syntax in given the grammar. +concretes2canonical opts absname gr = + [(cncname,concrete2canonical opts gr cenv absname cnc cncmod) + | let cenv = resourceValues opts gr, + cnc<-allConcretes gr absname, + let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath + Ok cncmod = lookupModule gr cnc + ] + +-- | Generate Canonical GF for the given concrete module. +-- The only options that make a difference are +-- @-haskell=noprefix@ and @-haskell=variants@. +concrete2canonical opts gr cenv absname cnc modinfo = + Concrete (modId cnc) (modId absname) + (neededParamTypes S.empty (params defs)) + [lincat|(_,Left lincat)<-defs] + [lin|(_,Right lin)<-defs] + where + defs = concatMap (toCanonical gr absname cenv) . + M.toList $ + jments modinfo + + params = S.toList . S.unions . map fst + + 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) + +toCanonical gr absname cenv (name,jment) = + case jment of + CncCat (Just (L loc typ)) _ _ pprn _ -> + [(pts,Left (LincatDef (gId name) (convType ntyp)))] + where + pts = paramTypes gr ntyp + ntyp = nf loc typ + CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> + [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] + where + tts = tableTypes gr [e'] +-- Ok abstype = lookupFunType gr absname name +-- (absctx,_abscat,_absargs) = typeForm abstype + e' = unAbs (length params) $ + nf loc (mkAbs params (mkApp def (map Vr args))) + params = [(b,x)|(b,x,_)<-ctx] + args = map snd params +-- abs_args = map (prefixIdent "abs_") args +-- lhs = [ConP (aId name) (map VarP abs_args)] +-- rhs = foldr letlin e' (zip args absctx) + + AnyInd _ m -> case lookupOrigInfo gr (m,name) of + Ok (m,jment) -> toCanonical gr absname cenv (name,jment) + _ -> [] + _ -> [] + where + nf loc = normalForm cenv (L loc name) +-- aId n = prefixIdent "A." (gId n) + + unAbs 0 t = t + unAbs n (Abs _ _ t) = unAbs (n-1) t + unAbs _ t = t + + +con = Cn . identS +{- +tableTypes gr ts = S.unions (map tabtys ts) + where + tabtys t = + case t of + ConcatValue v1 v2 -> S.union (tabtys v1) (tabtys v2) + TableValue t tvs -> S.unions (paramTypes gr t:[tabtys t|TableRowValue _ t<-tvs]) + VTableValue t ts -> (S.unions (paramTypes gr t:map tabtys ts)) + Projection lv l -> tabtys lv + Selection tv pv -> S.union (tabtys tv) (tabtys pv) + VariantValue vs -> S.unions (map tabtys vs) + RecordValue rvs -> S.unions [tabtys t|RecordRowValue _ t<-rvs] + TupleValue lvs -> S.unions (map tabtys lvs) + _ -> S.empty +-} +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 + +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 = trace ("Ignore: "++show t) S.empty + + +{- +records ts = S.unions (map recs ts) + where + recs t = + case t of + R r -> S.insert (labels r) (records (map (snd.snd) r)) + RecType r -> S.insert (labels r) (records (map snd r)) + _ -> collectOp recs t + + labels = sort . filter (not . isLockLabel) . map fst + + +coerce env ty t = + case (ty,t) of + (_,Let d t) -> Let d (coerce (extend env d) ty t) + (_,FV ts) -> FV (map (coerce env ty) ts) + (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts) + (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs) + (RecType rt,R r) -> + R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]] + (RecType rt,Vr 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 (map fst rt)) t + _ -> trace ("no coerce to "++render ty) t + _ -> t + where + extend env (x,(Just ty,rhs)) = (x,ty):env + extend env _ = env +-} +convert gr = convert' gr [] + +convert' gr vs = ppT + where + ppT0 = convert' gr vs + ppTv vs' = convert' gr vs' + + ppT t = + case t of + -- Only for 'let' inserted on the top-level by this converter: +-- Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t) +-- Abs b x t -> ... +-- V ty ts -> VTableValue (convType ty) (map ppT ts) + V ty ts -> TableValue (convType ty) [TableRowValue (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 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 -> IntConstant n + Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n)) + QC (m,n) -> ParamConstant (Param (gId (qual m n)) []) + K s -> StrConstant s + Empty -> StrConstant "" + FV ts -> VariantValue (map ppT ts) + Alts t' vs -> alts vs (ppT t') + _ -> error $ "convert' "++show t + + ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t) + + ppPredef n = + case predef n of + Ok BIND -> c "Predef.BIND" + Ok SOFT_BIND -> c "Predef.SOFT_BIND" + Ok SOFT_SPACE -> c "Predef.SOFT_SPACE" + Ok CAPIT -> c "Predef.CAPIT" + Ok ALL_CAPIT -> c "Predef.ALL_CAPIT" + _ -> VarValue (gId n) + + ppP p = + case p of + PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) + PP (m,c) ps -> ParamPattern (Param (gId (qual 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) -} + 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 (Strs ts) = concatMap pre ts + pre (EPatt p) = pat p + pre t = error $ "pre "++show t + + pat (PString s) = [s] + pat (PAlt p1 p2) = pat p1++pat p2 + pat p = error $ "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) + + join = id + +-- 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 List (map ppT ts) + else Lets [(ev i,ppT t)|(i,t)<-defs] (List (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] +-} + +concatValue v1 v2 = + case (v1,v2) of + (StrConstant "",_) -> v2 + (_,StrConstant "") -> v1 + _ -> ConcatValue v1 v2 + +projection r l = maybe (Projection r l) id (proj r l) + +proj r l = + case r of + RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of + [v] -> Just v + _ -> Nothing + _ -> Nothing + +selection t v = + case t of + TableValue tt r -> + case nub [rv|TableRowValue _ rv<-keep] of + [rv] -> rv + _ -> Selection (TableValue tt r') v + where + r' = if null discard + then r + else keep++[TableRowValue WildPattern impossible] + (keep,discard) = partition (mightMatchRow v) r + _ -> Selection t v + +impossible = ErrorValue "impossible" + +mightMatchRow v (TableRowValue p _) = + case p of + WildPattern -> True + _ -> mightMatch v p + +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 (flip mightMatch p) (proj v l) | RecordRow l p<-rp] + _ -> False + _ -> True + +patVars p = + case p of + PV x -> [x] + PAs x p -> x:patVars p + _ -> collectPattOp patVars p + +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 (gId (qual m n))) + Q (m,n) -> ParamType (ParamTypeId (gId (qual m n))) + _ -> error $ "Missing case in convType for: "++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 ("convSort "++show k) + +toParamType t = case convType t of + ParamType pt -> pt + _ -> error ("toParamType "++show t) + +toParamId t = case toParamType t of + ParamTypeId p -> p + +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 = gId (qual m n) + Ok (m,ResOper _ (Just (L _ t))) + | m==cPredef && n==cInts -> + ((S.empty,S.empty),[]) {- + ((S.singleton (m,n),S.empty), + [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-} + | otherwise -> + ((S.singleton (m,n),paramTypes gr t), + [ParamAliasDef (gId (qual m n)) (convType t)]) + _ -> ((S.empty,S.empty),[]) + where + param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx] + argTypes = S.unions . map argTypes1 + argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] + +qual :: ModuleName -> Ident -> Ident +qual m = prefixIdent (render m++"_") + + +lblId = LabelId . render -- hmm +modId (MN m) = ModId (showIdent m) + +class FromIdent i where gId :: Ident -> i + +instance FromIdent VarId where + gId i = if isWildIdent i then Anonymous else VarId (showIdent i) + +instance FromIdent C.FunId where gId = C.FunId . showIdent +instance FromIdent CatId where gId = CatId . showIdent +instance FromIdent ParamId where gId = ParamId . showIdent +instance FromIdent VarValueId where gId = VarValueId . showIdent diff --git a/src/compiler/GF/Compile/Export.hs b/src/compiler/GF/Compile/Export.hs index d844e300a..5403298f9 100644 --- a/src/compiler/GF/Compile/Export.hs +++ b/src/compiler/GF/Compile/Export.hs @@ -3,6 +3,7 @@ module GF.Compile.Export where import PGF import PGF.Internal(ppPGF) import GF.Compile.PGFtoHaskell +import GF.Compile.PGFtoAbstract import GF.Compile.PGFtoJava import GF.Compile.PGFtoProlog import GF.Compile.PGFtoJS @@ -34,6 +35,7 @@ exportPGF :: Options exportPGF opts fmt pgf = case fmt of FmtPGFPretty -> multi "txt" (render . ppPGF) + FmtCanonicalGF -> canon "gf" (render80 . abstract2canonical) FmtJavaScript -> multi "js" pgf2js FmtPython -> multi "py" pgf2python FmtHaskell -> multi "hs" (grammar2haskell opts name) @@ -56,10 +58,12 @@ exportPGF opts fmt pgf = multi :: String -> (PGF -> String) -> [(FilePath,String)] multi ext pr = [(name <.> ext, pr pgf)] + canon ext pr = [("canonical"name<.>ext,pr pgf)] single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- languages pgf] + -- | Get the name of the concrete syntax to generate output from. -- FIXME: there should be an option to change this. outputConcr :: PGF -> CId diff --git a/src/compiler/GF/Compile/PGFtoAbstract.hs b/src/compiler/GF/Compile/PGFtoAbstract.hs new file mode 100644 index 000000000..032a53f81 --- /dev/null +++ b/src/compiler/GF/Compile/PGFtoAbstract.hs @@ -0,0 +1,42 @@ +-- | Extract the abstract syntax from a PGF and convert to it +-- the AST for canonical GF grammars +module GF.Compile.PGFtoAbstract(abstract2canonical) where +import qualified Data.Map as M +import PGF(CId,mkCId,showCId,wildCId,unType,abstractName) +import PGF.Internal(abstract,cats,funs) +import GF.Grammar.Canonical + + +abstract2canonical pgf = Abstract (gId (abstractName pgf)) cs fs + where + abstr = abstract pgf + cs = [CatDef (gId c) (convHs' hs) | + (c,(hs,_,_)) <- M.toList (cats abstr), + c `notElem` predefCat] + fs = [FunDef (gId f) (convT ty) | (f,(ty,ar,_,_)) <- M.toList (funs abstr)] + +predefCat = map mkCId ["Float","Int","String"] + +convHs' = map convH' +convH' (bt,name,ty) = + case unType ty of + ([],name,[]) -> gId name -- !! + +convT t = + case unType t of + (hypos,name,[]) -> Type (convHs hypos) (TypeApp (gId name) []) -- !! + +convHs = map convH + +convH (bt,name,ty) = TypeBinding (gId name) (convT ty) + +-------------------------------------------------------------------------------- + +class FromCId i where gId :: CId -> i + +instance FromCId FunId where gId = FunId . showCId +instance FromCId CatId where gId = CatId . showCId +instance FromCId ModId where gId = ModId . showCId + +instance FromCId VarId where + gId i = if i==wildCId then Anonymous else VarId (showCId i) diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs index aa7b80268..334bbd592 100644 --- a/src/compiler/GF/Compiler.hs +++ b/src/compiler/GF/Compiler.hs @@ -7,6 +7,7 @@ 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.ConcreteToCanonical(concretes2canonical) import GF.Compile.CFGtoPGF import GF.Compile.GetGrammar import GF.Grammar.BNFC @@ -17,7 +18,7 @@ import GF.Infra.UseIO import GF.Infra.Option import GF.Data.ErrM import GF.System.Directory -import GF.Text.Pretty(render) +import GF.Text.Pretty(render,render80) import Data.Maybe import qualified Data.Map as Map @@ -47,7 +48,7 @@ mainGFC opts fs = do compileSourceFiles :: Options -> [FilePath] -> IOE () compileSourceFiles opts fs = do output <- batchCompile opts fs - cncs2haskell output + exportCncs output unless (flag optStopAfterPhase opts == Compile) $ linkGrammars opts output where @@ -55,15 +56,23 @@ compileSourceFiles opts fs = batchCompile' opts fs = do (t,cnc_gr) <- S.batchCompile opts fs return (t,[cnc_gr]) - cncs2haskell output = - when (FmtHaskell `elem` flag optOutputFormats opts && - haskellOption opts HaskellConcrete) $ - mapM_ cnc2haskell (snd output) + exportCncs output = + do when (FmtHaskell `elem` ofmts && haskellOption opts HaskellConcrete) $ + mapM_ cnc2haskell (snd output) + when (FmtCanonicalGF `elem` ofmts) $ + mapM_ cnc2canonical (snd output) + where + ofmts = flag optOutputFormats opts cnc2haskell (cnc,gr) = - mapM_ writeHs $ concretes2haskell opts (srcAbsName gr cnc) gr + do mapM_ writeExport $ concretes2haskell opts (srcAbsName gr cnc) gr - writeHs (path,s) = writing opts path $ writeUTF8File path s + cnc2canonical (cnc,gr) = + do createDirectoryIfMissing False "canonical" + mapM_ (writeExport.fmap render80) $ + concretes2canonical opts (srcAbsName gr cnc) gr + + writeExport (path,s) = writing opts path $ writeUTF8File path s -- | Create a @.pgf@ file (and possibly files in other formats, if specified diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs new file mode 100644 index 000000000..2a164c578 --- /dev/null +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -0,0 +1,250 @@ +-- | 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. +module GF.Grammar.Canonical where +import GF.Text.Pretty + +-- | A Complete grammar +data Grammar = Grammar Abstract [Concrete] deriving Show + +-------------------------------------------------------------------------------- +-- ** Abstract Syntax + +-- | Abstract Syntax +data Abstract = Abstract ModId [CatDef] [FunDef] deriving Show + +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 [ParamDef] [LincatDef] [LinDef] + deriving Show + +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 + | ErrorValue String + | FloatConstant Float + | IntConstant Int + | ParamConstant ParamValue + | RecordValue [RecordRowValue] + | StrConstant String + | TableValue LinType [TableRowValue] +--- | VTableValue LinType [LinValue] + | TupleValue [LinValue] + | VariantValue [LinValue] + | VarValue VarValueId + | PreValue [([String], LinValue)] LinValue + | Projection LinValue LabelId + | Selection LinValue LinValue + deriving (Eq,Show) + +data LinPattern = ParamPattern ParamPattern + | RecordPattern [RecordRow LinPattern] + | WildPattern + deriving (Eq,Show) + +type ParamValue = Param LinValue +type ParamPattern = Param LinPattern +type ParamValueDef = Param ParamId + +data Param arg = Param ParamId [arg] deriving (Eq,Show) + +type RecordRowType = RecordRow LinType +type RecordRowValue = RecordRow LinValue + +data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show) +data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Show) + +-- *** Identifiers in Concrete Syntax + +newtype LabelId = LabelId String deriving (Eq,Ord,Show) +data VarValueId = VarValueId String deriving (Eq,Show) + +-- | Name of param type or param value +newtype ParamId = ParamId String deriving (Eq,Ord,Show) + +-------------------------------------------------------------------------------- +-- ** Used in both Abstract and Concrete Syntax + +newtype ModId = ModId String deriving (Eq,Show) + +newtype CatId = CatId String deriving (Eq,Show) +newtype FunId = FunId String deriving (Eq,Show) + +data VarId = Anonymous | VarId String deriving Show + +-------------------------------------------------------------------------------- +-- ** Pretty printing + +instance Pretty Grammar where + pp (Grammar abs cncs) = abs $+$ vcat cncs + +instance Pretty Abstract where + pp (Abstract m cats funs) = "abstract" <+> m <+> "=" <+> "{" $$ + "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 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 -> pt <+> "=>" <+> 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 + Projection lv l -> ppA lv<>"."<>l + Selection tv pv -> ppA tv<>"!"<>ppA pv + VariantValue vs -> "variants"<+>block vs + _ -> ppA lv + +instance PPA LinValue where + ppA lv = case lv of + FloatConstant f -> pp f + IntConstant n -> pp n + ParamConstant pv -> ppA pv + 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) + StrConstant s -> doubleQuotes s -- hmm + TableValue _ tvs -> "table"<+>block tvs +-- VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts) + TupleValue lvs -> "<"<>punctuate "," lvs<>">" + VarValue v -> pp v + _ -> parens lv + +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 + RecordPattern r -> block r + WildPattern -> pp "_" + _ -> parens p + +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 TableRowValue where + pp (TableRowValue 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 ParamId where pp = ppA +instance PPA ParamId where ppA (ParamId s) = pp s +instance Pretty VarValueId where pp (VarValueId s) = pp s + +-------------------------------------------------------------------------------- +-- | 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) \ No newline at end of file diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index fa0e91980..bd65db2f6 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -87,6 +87,7 @@ data Phase = Preproc | Convert | Compile | Link deriving (Show,Eq,Ord) data OutputFormat = FmtPGFPretty + | FmtCanonicalGF | FmtJavaScript | FmtPython | FmtHaskell @@ -468,6 +469,7 @@ outputFormats = map fst outputFormatsExpl outputFormatsExpl :: [((String,OutputFormat),String)] outputFormatsExpl = [(("pgf_pretty", FmtPGFPretty),"human-readable pgf"), + (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"), (("js", FmtJavaScript),"JavaScript (whole grammar)"), (("python", FmtPython),"Python (whole grammar)"), (("haskell", FmtHaskell),"Haskell (abstract syntax)"), diff --git a/src/compiler/GF/Text/Pretty.hs b/src/compiler/GF/Text/Pretty.hs index 29ca7f131..5c87ea6a3 100644 --- a/src/compiler/GF/Text/Pretty.hs +++ b/src/compiler/GF/Text/Pretty.hs @@ -20,6 +20,7 @@ instance Pretty a => Pretty [a] where ppList = fsep . map pp -- hmm render x = PP.render (pp x) +render80 x = renderStyle style{lineLength=80,ribbonsPerLine=1} x renderStyle s x = PP.renderStyle s (pp x) infixl 5 $$,$+$