uuagc-0.9.54: src-ag/PrintCode.ag
PRAGMA strictdata
PRAGMA optimize
PRAGMA bangpats
PRAGMA strictwrap
INCLUDE "Code.ag"
INCLUDE "Patterns.ag"
imports
{
import Data.Char (isAlphaNum)
import Pretty
import Code
import Options
import CommonTypes (attrname, _LOC, nullIdent)
import Data.List(intersperse)
import System.IO
import System.Directory
import System.FilePath
import CommonTypes(BlockInfo, BlockKind(..))
}
{
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
}
ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ]
SEM Chunk
| Chunk
loc.outputfile = if sepSemMods @lhs.options
then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name)
else @lhs.mainFile
ATTR Program [ options:{Options} | | output:{PP_Docs} ]
ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ]
ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ]
ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ]
ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ]
SEM Program | Program
loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered }
SEM Program
| Program chunks.nested = nest @lhs.options
SEM Exprs
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM CaseAlts
| Cons lhs.pps = @hd.pps ++ @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 Program
| Program lhs.output = @chunks.pps
SEM Chunk
| Chunk lhs.pps = @comment.pp
: @info.pps
++ @dataDef.pps
++ @cataFun.pps
++ @semDom.pps
++ @semWrapper.pps
++ @semFunctions.pps
++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap]
SEM Decl
| Decl lhs.pp = @left.pp >#< "="
>-< indent 4 @rhs.pp
| Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp
| BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp
| Data lhs.pp = "data" >#< hv_sp (@name : @params)
>#< ( case @alts.pps of
[] -> empty
(x:xs) -> "=" >#< x
>-< vlist (map ("|" >#<) xs)
>-< if null @derivings
then empty
else "deriving" >#< ppTuple False (map text @derivings)
)
| NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp
| Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp
| TSig lhs.pp = @name >#< "::" >#< @tp.pp
| Comment lhs.pp = if '\n' `elem` @txt
then "{-" >-< vlist (lines @txt) >-< "-}"
else "--" >#< @txt
| PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}"
| Resume lhs.pp = if @monadic
then @left.pp >#< "<-" >#< @rhs.pp
else @left.pp >#< "=" >-< indent 4 @rhs.pp
| EvalDecl loc.strat = if breadthFirstStrict @lhs.options
then "stepwiseEval"
else "lazyEval"
lhs.pp = if breadthFirst @lhs.options
then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of"
>-< indent 4 (
pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val"
)
else @left.pp >#< "=" >#< @rhs.pp
SEM Expr
| Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps)
>-< "in " >#< @body.pp
)
| Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
>-< (vlist @alts.pps)
)
| Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps
>-< ("return" >#< @body.pp))
)
| Lambda loc.strictParams = if strictSems @lhs.options
then @args.pps
else []
loc.addBang = if bangpats @lhs.options
then \p -> pp_parens ("!" >|< p)
else id
lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
>-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
)
| TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps
| UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps
| 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 = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"")
>-< pp_parens @expr.pp
)
| PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}"
op = if @onNewLine
then (>-<)
else (>#<)
leftOp x y = if @onLeftSide
then x `op` y
else y
rightOp x y = if @onLeftSide
then x
else x `op` y
in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc)
| LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}"
>-< ""
| TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp)
| ResultExpr lhs.pp = if breadthFirst @lhs.options
then "final" >#<
pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp)
else @expr.pp
| InvokeExpr lhs.pp = if breadthFirst @lhs.options
then "invoke" >#< pp_parens @expr.pp >#< pp_parens (
@nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps))
else @expr.pp >#< hv_sp @args.pps
| ResumeExpr lhs.pp = if breadthFirst @lhs.options
then pp_parens ("resume" >#< pp_parens @expr.pp
>-< indent 2 (pp_parens ( "\\" >|<
pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg"))
>#< "->"
>-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg"
>-< indent 2 ("in" >#< @rhs.pp)
))))
else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of"
>-< ("{" >#< @left.pp >#< "->")
>-< indent 4 (@rhs.pp >#< "}")
)
| SemFun loc.strictParams = if strictSems @lhs.options
then @args.pps
else []
loc.addBang = if bangpats @lhs.options
then \p -> pp_parens ("!" >|< p)
else id
lhs.pp = if breadthFirst @lhs.options
then "Child" >#< pp_parens ( "\\" >|<
pp_parens (@nt >|< "_Inh" >#<
ppTuple False (map @loc.addBang @args.pps)) >#< "->"
>-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp))
else if null @args.pps
then @body.pp
else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->"
>-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp)
)
SEM CaseAlt
| CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"]
SEM DataAlt
| DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps)
| Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps
SEM NamedType
| Named lhs.pp = if @strict
then @name >#< "::" >#< "!" >|< pp_parens @tp.pp
else @name >#< "::" >#< @tp.pp
SEM Lhs
| Pattern3 TupleLhs UnboxedTupleLhs
loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
| Pattern3
loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True")
loc.hasStrictVars = not (null @pat3.strictVars)
| TupleLhs UnboxedTupleLhs
loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet
then map text @comps `ppMultiSeqH` (pp "True")
else pp "True"
loc.hasStrictVars = not (null @comps)
| Fun
loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id
loc.hasStrictVars = not (null @args.pps)
loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True")
| TupleLhs UnboxedTupleLhs Fun
loc.addBang = if bangpats @lhs.options
then \p -> "!" >|< p
else id
| Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp
| Pattern3SM lhs.pp = @pat3.pp'
| TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps)
| UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps)
| Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps))
| Unwrap lhs.pp = pp_parens (@name >#< @sub.pp)
SEM Type [ | | prec:Int ]
| Arr lhs.prec = 2
.pp = @loc.l >#< "->" >-< @loc.r
loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp
.r = if @right.prec < 2 then pp_parens @right.pp else @right.pp
| TypeApp
lhs.pp = hv_sp (@func.pp : @args.pps)
| CtxApp
lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp
| QuantApp
lhs.pp = @left >#< @right.pp
| TupleType lhs.prec = 5
.pp = ppTuple @lhs.nested @tps.pps
| UnboxedTupleType lhs.prec = 5
.pp = ppUnboxedTuple @lhs.nested @tps.pps
| List lhs.prec = 5
.pp = "[" >|< @tp.pp >|< "]"
| SimpleType lhs.prec = 5
.pp = if reallySimple @txt then text @txt else pp_parens (text @txt)
| NontermType lhs.prec = 5
lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params
loc.prefix = if @deforested
then text "T_"
else empty
| TMaybe lhs.prec = 5
lhs.pp = text "Maybe" >#< pp_parens @tp.pp
| TEither lhs.prec = 5
lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp
| TMap lhs.prec = 5
lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp
| TIntMap lhs.prec = 5
lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp
| TSet lhs.prec = 5
lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp
| TIntSet lhs.prec = 5
lhs.pp = text "Data.IntSet.IntSet"
{
reallySimple :: String -> Bool
reallySimple = and . map (\x -> isAlphaNum x || x=='_')
ppTuple :: Bool -> [PP_Doc] -> PP_Doc
ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps
ppTuple False pps = "(" >|< pp_block " " ")" "," pps
ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc
ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps
ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps
}
-------------------------------------------------------------------------------
-- Strict data fields
-------------------------------------------------------------------------------
ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ]
SEM Decl
| Data alts.strictPre = if @strict then pp "!" else empty
-------------------------------------------------------------------------------
-- Strict variables
-------------------------------------------------------------------------------
ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ]
SEM Pattern
| Alias
loc.strictVar
= if strictCases @lhs.options && not @lhs.isDeclOfLet
then [@loc.ppVar]
else []
loc.strictPatVars
= if stricterCases @lhs.options && not @lhs.isDeclOfLet
then @pat.strictVars
else []
lhs.strictVars
= @loc.strictVar ++ @loc.strictPatVars
| Irrefutable
lhs.strictVars = []
-------------------------------------------------------------------------------
-- Pretty printing patterns
-------------------------------------------------------------------------------
SEM Patterns [ | | pps : {[PP_Doc]} ]
| Cons lhs.pps = @hd.pp : @tl.pps
| Nil lhs.pps = []
SEM Pattern
| Constr Product Alias
loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable
then \p -> "!" >|< p
else id
SEM Pattern [ | | pp:PP_Doc ]
| Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps
| Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps
| Alias loc.ppVar = pp (attrname @lhs.options False @field @attr)
loc.ppVarBang = @loc.addBang $ @loc.ppVar
lhs.pp = if @pat.isUnderscore
then @loc.ppVarBang
else @loc.ppVarBang >|< "@" >|< @pat.pp
| Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp
| Underscore lhs.pp = text "_"
SEM Pattern [ | | isUnderscore:{Bool}]
| Constr lhs.isUnderscore = False
| Product lhs.isUnderscore = False
| Alias lhs.isUnderscore = False
| Underscore lhs.isUnderscore = True
ATTR Pattern Patterns [ belowIrrefutable : Bool | | ]
SEM Pattern
| Irrefutable
pat.belowIrrefutable = True
SEM Lhs
| Pattern3 Pattern3SM
pat3.belowIrrefutable = False
-------------------------------------------------------------------------------
-- Pretty printing patterns for SM
-------------------------------------------------------------------------------
SEM Patterns [ | | pps' : {[PP_Doc]} ]
| Cons lhs.pps' = @hd.pp' : @tl.pps'
| Nil lhs.pps' = []
SEM Pattern [ | | pp':PP_Doc ]
| Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps')
| Product lhs.pp' = pp_block "(" ")" "," @pats.pps'
| Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr
| otherwise = attrname @lhs.options False @field @attr
in attribute >|< "@" >|< @pat.pp'
| Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp
| Underscore lhs.pp' = text "_"
{
locname' :: Identifier -> [Char]
locname' n = "_loc_" ++ getName n
}
-------------------------------------------------------------------------------
-- Determine if inside a Let
-------------------------------------------------------------------------------
ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ]
SEM Program
| Program
chunks.isDeclOfLet = False
SEM Expr
| Let
decls.isDeclOfLet = True
| Do
stmts.isDeclOfLet = False
| ResumeExpr
left.isDeclOfLet = False
SEM CaseAlt
| CaseAlt
left.isDeclOfLet = False
-------------------------------------------------------------------------------
-- Alternative code printing to separate modules
-------------------------------------------------------------------------------
ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ]
ATTR Program Chunks Chunk
[ importBlocks : PP_Doc
pragmaBlocks : String
textBlocks : PP_Doc
textBlockMap : {Map BlockInfo PP_Doc}
optionsLine : String
mainFile : String
mainName : String
moduleHeader : {String -> String -> String -> Bool -> String}
| | ]
SEM Program
| Program
loc.mainModuleFile = @lhs.mainFile
loc.genMainModule
= writeModule @loc.mainModuleFile
( [ pp $ @lhs.pragmaBlocks
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName "" "" False
, pp $ ("import " ++ @lhs.mainName ++ "_common\n")
]
++ map pp @chunks.imports
++ map vlist @chunks.appendMain
++ [@lhs.mainBlocksDoc]
)
loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
loc.genCommonModule
= writeModule @loc.commonFile
( [ pp $ @lhs.pragmaBlocks
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
, @lhs.importBlocks
, @lhs.textBlocks
]
++ map vlist @chunks.appendCommon
)
lhs.genIO = do @loc.genMainModule
@loc.genCommonModule
@chunks.genSems
{
renderDocs :: [PP_Doc] -> String
renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
}
ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ]
SEM Chunk
| Chunk
lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"]
ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ]
SEM Chunk
| Chunk
lhs.appendCommon
= [ [@comment.pp]
, @dataDef.pps
, @semDom.pps
, if reference @lhs.options then @semWrapper.pps else []
]
lhs.appendMain
= [ [@comment.pp]
, @cataFun.pps
, if reference @lhs.options then [] else @semWrapper.pps
]
ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]
SEM Chunk
| Chunk
lhs.genSems
= writeModule @loc.outputfile
[ pp $ @lhs.pragmaBlocks
, pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap
, pp $ @lhs.optionsLine
, pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True
, pp $ ("import " ++ @lhs.mainName ++ "_common\n")
, pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap
, @comment.pp
, vlist_sep "" @info.pps
, vlist_sep "" @semFunctions.pps
, Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap
]
SEM Chunk
| Chunk
loc.exports = concat $ intersperse "," @semNames
{
writeModule :: FilePath -> [PP_Doc] -> IO ()
writeModule path docs
= do bExists <- doesFileExist path
if bExists
then do input <- readFile path
seq (length input) (return ())
if input /= output
then dumpIt
else return ()
else dumpIt
where
output = renderDocs docs
dumpIt = writeFile path output
}