uuagc-0.9.50: src-ag/PrintOcamlCode.ag
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "Code.ag"
INCLUDE "Patterns.ag"
imports
{
import Pretty
import Code
import Patterns
import Options
import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either)
import Data.List(intersperse,intercalate)
import Data.Char(toLower)
}
{
type PP_Docs = [PP_Doc]
ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeqH = ppMultiSeq' (>#<)
ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeqV = ppMultiSeq' (>-<)
ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc
ppMultiSeq' next strictArgs expr
= foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs
ppTuple :: Bool -> [PP_Doc] -> PP_Doc
ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
ppTuple False pps = "(" >|< pp_block " " ")" "," pps
}
--
-- Pass options down
--
ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ]
--
-- Collect outputs
--
ATTR Program [ | | output:{PP_Docs} ]
ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ]
ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ]
SEM Program
| Program lhs.output = @chunks.pps
SEM Exprs
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM CaseAlts
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM DataAlts
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Types
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM NamedTypes
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Decls
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Chunks
| Cons lhs.pps = @hd.pps ++ @tl.pps
| Nil lhs.pps = []
SEM Patterns
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
--
-- Individual cases
--
SEM Chunk
| Chunk lhs.pps = @comment.pp
: @info.pps
++ @dataDef.pps
++ @semDom.pps
++ @semFunctions.pps
++ @semWrapper.pps
++ @cataFun.pps
++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
SEM Decl
| Decl lhs.pp = if @lhs.isToplevel
then "let" >#< @left.pp >#< "="
>-< indent 4 @rhs.pp >#< ";;"
else "let" >#< @left.pp >#< "="
>-< indent 4 @rhs.pp >#< "in"
| Bind lhs.pp = error "pp of Decl.Bind not supported"
| BindLet lhs.pp = error "pp of Decl.BindLet not supported"
| Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name])
>#< ( case @alts.pps of
[] -> empty
(x:xs) -> "=" >#< x
>-< vlist (map ("|" >#<) xs)
)
>#< ";;"
| NewType lhs.pp = error "pp of Decl.NewType not supported"
| Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;"
| TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)"
| Comment lhs.pp = if '\n' `elem` @txt
then "(* " >-< vlist (lines @txt) >-< "*)"
else "(*" >#< @txt >#< "*)"
| PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported"
SEM Expr
| Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp])
| Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with"
>-< indent 2 ( case @alts.pps of
[] -> empty
(x:xs) -> " " >#< x
>-< vlist (map ("|" >#<) xs)
)
)
| Do lhs.pp = error "pp of Expr.Do not supported"
| Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->"
>-< indent 2 @body.pp )
| TupleExpr lhs.pp = ppTuple False @exprs.pps
| UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported"
| App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps
| SimpleExpr lhs.pp = text @txt
| TextExpr lhs.pp = vlist (map text @lns)
| Trace lhs.pp = @expr.pp
| PragmaExpr lhs.pp = @expr.pp
| LineExpr lhs.pp = @expr.pp
| TypedExpr lhs.pp = @expr.pp
SEM Lhs
| Pattern3 lhs.pp = @pat3.pp
| Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported"
| TupleLhs lhs.pp = ppTuple False (map text @comps)
| UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported"
| Fun lhs.pp = @name >#< hv_sp @args.pps
| Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)
SEM Type
| Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp)
| CtxApp lhs.pp = error "pp of Type.CtxApp not supported"
| TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp]))
| TupleType lhs.pp = pp_block "(" ")" "," @tps.pps
| UnboxedTupleType
lhs.pp = error "pp of Type.UnboxedTupleType is not supported"
| List lhs.pp = @tp.pp >#< "list"
| SimpleType lhs.pp = text @txt
| NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name])
| TMaybe lhs.pp = @tp.pp >#< "opt"
| TEither lhs.pp = error "pp of Type.TEither is not supported"
| TMap lhs.pp = error "pp of Type.TMap is not supported"
| TIntMap lhs.pp = error "pp of Type.TIntMap is not supported"
{
toOcamlTC :: String -> String
toOcamlTC (c:cs) = toLower c : cs
toOcamlTC xs = xs
}
SEM CaseAlt
| CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp
SEM DataAlt
| DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps)
| Record lhs.pp = pp_block "{" "}" ";" @args.pps
SEM NamedType
| Named lhs.pp = @name >#< ":" >#< @tp.pp
SEM Pattern
| Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps
| Product lhs.pp = pp_block "(" ")" "," @pats.pps
| Alias -- assuming here that there is only an underscore under an alias
lhs.pp = if @pat.isUnderscore
then pp (attrname @lhs.options False @field @attr)
else error "pp of Pattern.Alias is only supported in the form (x@_)"
| Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported"
| Underscore lhs.pp = text "_"
SEM Pattern [ | | isUnderscore:{Bool}]
| Constr lhs.isUnderscore = False
| Product lhs.isUnderscore = False
| Alias lhs.isUnderscore = False
| Underscore lhs.isUnderscore = True
--
-- Determine if a declaration is toplevel
--
ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ]
SEM Program
| Program
chunks.isToplevel = True
SEM Expr
| Let
decls.isToplevel = False
| Do
stmts.isToplevel = False