summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Compile/ConcreteToCanonical.hs404
-rw-r--r--src/compiler/GF/Compile/Export.hs4
-rw-r--r--src/compiler/GF/Compile/PGFtoAbstract.hs42
-rw-r--r--src/compiler/GF/Compiler.hs25
-rw-r--r--src/compiler/GF/Grammar/Canonical.hs250
-rw-r--r--src/compiler/GF/Infra/Option.hs2
-rw-r--r--src/compiler/GF/Text/Pretty.hs1
7 files changed, 720 insertions, 8 deletions
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 $$,$+$
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:39:22 +0000