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 Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}] ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ] ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] ATTR Type Types [ | | copy : SELF] 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 lhs.ppas = @hd.ppa : @tl.ppas | Nil lhs.pps = [] lhs.ppas = [] SEM Types | Cons lhs.pps = @hd.pp : @tl.pps | Nil lhs.pps = [] SEM NamedTypes | Cons lhs.pps = @hd.pp : @tl.pps lhs.ppas = @hd.ppa : @tl.ppas | Nil lhs.pps = [] lhs.ppas = [] 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 = "::" >#< 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) ) >-< foldr (>-<) empty @alts.ppas | NewType lhs.pp = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp | Type lhs.pp = "::" >#< 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 >#< "#*/" -- Not used in Clean | 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 >#< "#*/" -- Not used in Clean 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) lhs.ppa = empty | Record lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps lhs.ppa = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n)) >#< pp "=" >#< pp "x" ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _") in snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas SEM NamedType | Named lhs.pp = -- @name >#< "::" >#< if @strict then "!" >|< pp_parens @tp.pp else @tp.pp lhs.ppa = pp @name 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 = case @right.copy of Arr{} -> @loc.l >-< @loc.r _ -> @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 = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check | CtxApp lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) | 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 _ [x] = pp x ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps ppTuple False pps = "(" >|< pp_block " " ")" "," pps ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc ppUnboxedTuple = ppTuple --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 }