fay 0.1.1.0 → 0.1.2.0

raw patch · 7 files changed

+189/−161 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• fay.cabal +11/−71
• src/Docs.hs +1/−1
• src/Language/Fay.hs +113/−62
• src/Language/Fay/Compiler.hs +33/−18
• src/Language/Fay/Print.hs +2/−0
• src/Language/Fay/Types.hs +29/−9
• tests/1.hs +0/−0

@@ -1,8 +1,10 @@ name:                fay-version:             0.1.1.0+version:             0.1.2.0 synopsis:            A compiler for Fay, a Haskell subset that compiles to JavaScript.-description:         Fay is a strict subset of Haskell which can be compiled (type-checked) -                     with GHC, and compiled to JavaScript.+description:         Fay is a proper subset of Haskell which can be compiled (type-checked) +                     with GHC, and compiled to JavaScript. It is lazy, pure, with a Fay monad,+                     an FFI, tail-recursion optimization (experimental). It implements no type+                     system, for type-checking you should use GHC.                      .                      /Documentation/                      .@@ -18,78 +20,16 @@                      .                      /Release Notes/                      .-                     Lots of documentation updates, some runtime-                     fixes, some more examples, tail-call optimization-                     prototype.-                     .-                     * Add analytics to .cabal.-                     .-                     * Fix types for ghc.-                     .-                     * Use continue (for now) for TCO (refs #19).-                     .-                     * Tail recursive optimization prototype (refs #19).-                     .-                     * Tail recursive example doc.-                     .-                     * Ref example.-                     .-                     * fromInteger/fromRational in the runtime (closes #20).-                     .-                     * Add missing operators to Prelude and built-ins list (closes #16).-                     .-                     * Throw error about unsupported `where' (closes #17).-                     .-                     * Fix silly enumFromTo mistake.-                     .-                     * A test-case that tail-recursive functions run iteratively.-                     .-                     * Optimize constant patterns slightly, shaves off some time.-                     .-                     * Add Fay.Show (preliminary implementation).-                     .-                     * Add data/show example.-                     .-                     * Add note about generating docs.-                     .-                     * Add note that you need nodejs installed to run the tests.-                     .-                     * Include google analytics in docs and generate index.html rather than home.html.-                     .-                     * Updated dom example with onload handler.-                     .-                     * Remove max-width to fix firefox.-                     .-                     * Mention minifying slightly in docs.-                     .-                     * Remove language-javascript dependency.-                     .-                     * Remove non-ascii character in runtime.js-                     .-                     * Don't print counts in fay-tests.-                     .-                     * Add small note about livescript.-                     .-                     * Added fork on github for docs.-                     .-                     * Use === instead of == for jseq (closes #6).-                     .-                     * Some word break on the pre's.-                     .-                     * Rename modules from Main to X (closes #5).-                     .-                     * Ignore more stuff.-                     .-                     * Toggle examples.+                     * Some tidying and module export support.                      .-                     * Put examples side-by-side (closes #3).+                     * Export an object w/ export lists. This shouldn't break existing uses, but will break API uses (refs #8).                      .-                     * s/strict/proper to avoid confusion.+                     * Tidy up code a bit, switch to a newtype monad.                      .-                     * Convert from function expression assignments to function definitions+                     * Add CHANGELOG and RELEASE NOTES for Hackage update.                      .                      See full history at: <https://github.com/chrisdone/fay/commits>-homepage:            http://chrisdone.com/fay+homepage:            http://fay-lang.org/ license:             BSD3 license-file:        LICENSE author:              Chris Done@@ -106,7 +46,7 @@                      -- Test cases                      tests/10 tests/10.hs tests/11 tests/11.hs tests/12 tests/12.hs tests/13                      tests/13.hs tests/14 tests/14.hs tests/15 tests/15.hs tests/16 tests/16.hs-                     tests/17 tests/17.hs tests/18 tests/18.hs tests/19 tests/19.hs tests/1.hs+                     tests/17 tests/17.hs tests/18 tests/18.hs tests/19 tests/19.hs                      tests/2 tests/20 tests/20.hs tests/21 tests/21.hs tests/22 tests/22.hs                      tests/23 tests/23.hs tests/24 tests/24.hs tests/25.hs tests/26 tests/26.hs                      tests/2.hs tests/3 tests/3.hs tests/4 tests/4.hs tests/5 tests/5.hs tests/6

@@ -44,7 +44,7 @@           putStrLn $ "Compiling " ++ file ++ " ..."           result <- compileViaStr def compileModule contents           case result of-            Right javascript -> return javascript+            Right (javascript,state) -> return javascript             Left err -> throw err         titlize = takeWhile (/='.') . upperize . takeFileName           where upperize (x:xs) = toUpper x : xs

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -5,8 +6,7 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE ViewPatterns          #-}-{-# OPTIONS -fno-warn-orphans #-}-{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}  -- | The Haskell→Javascript compiler. @@ -19,9 +19,10 @@  import Control.Applicative import Control.Monad.Error-import Control.Monad.Reader+import Control.Monad.State import Control.Monad.IO import Data.List+import Data.Maybe import Data.String import Language.Haskell.Exts -- import System.Process.Extra@@ -30,19 +31,24 @@ -- Top level entry points  -- | Compile something that compiles to something else.-compile :: CompilesTo from to => Config -> from -> IO (Either CompileError to)+compile :: CompilesTo from to => CompileConfig -> from -> IO (Either CompileError (to,CompileState)) compile config = runCompile config . compileTo  -- | Run the compiler.-runCompile :: Config -> Compile a -> IO (Either CompileError a)-runCompile config m = runErrorT (runReaderT m config)+runCompile :: CompileConfig -> Compile a -> IO (Either CompileError (a,CompileState))+runCompile config m = runErrorT (runStateT (unCompile m) state) where+  state = CompileState { stateConfig  = config+                       , stateExports = []+                       , stateModuleName = "Main"+                       , stateExportAll = True+                       }  -- | Compile a Haskell source string to a JavaScript source string. compileViaStr :: (Show from,Show to,CompilesTo from to)-              => Config+              => CompileConfig               -> (from -> Compile to)               -> String-              -> IO (Either CompileError String)+              -> IO (Either CompileError (String,CompileState)) compileViaStr config with from =   runCompile config              (parseResult (throwError . uncurry ParseError)@@ -51,16 +57,18 @@  -- | Compile a Haskell source string to a JavaScript source string. compileToAst :: (Show from,Show to,CompilesTo from to)-              => Config+              => CompileConfig               -> (from -> Compile to)               -> String-              -> IO (Either CompileError to)+              -> IO (Either CompileError (to,CompileState)) compileToAst config with from =   runCompile config              (parseResult (throwError . uncurry ParseError)                           with                           (parse from)) +-- | Compile from a string.+compileFromStr :: (Parseable a, MonadError CompileError m) => (a -> m a1) -> String -> m a1 compileFromStr with from =   parseResult (throwError . uncurry ParseError)               (with)@@ -83,7 +91,11 @@  -- | Compile Haskell module. compileModule :: Module -> Compile [JsStmt]-compileModule (Module _ modulename pragmas Nothing exports imports decls) = do+compileModule (Module _ modulename _pragmas Nothing exports imports decls) = do+  modify $ \s -> s { stateModuleName = modulename+                   , stateExportAll = isNothing exports+                   }+  mapM_ emitExport (fromMaybe [] exports)   imported <- fmap concat (mapM compileImport imports)   current <- compileDecls decls   return (imported ++ current)@@ -118,6 +130,7 @@                          xs <- n                          return (x ++ xs) +-- | Compile a declaration. compileDecl :: Decl -> Compile [JsStmt] compileDecl decl =   case decl of@@ -132,6 +145,7 @@     InstDecl{} -> return [] -- FIXME: Ignore.     _ -> throwError (UnsupportedDeclaration decl) +-- | Compile a top-level pattern bind. compilePatBind :: Maybe Type -> Decl -> Compile [JsStmt] compilePatBind sig pat =   case pat of@@ -155,16 +169,20 @@           = Just (ident,name,typ)         ffiExp _ = Nothing +-- | Compile a normal simple pattern binding. compileNormalPatBind :: Name -> Exp -> Compile [JsStmt] compileNormalPatBind ident rhs = do   body <- compileExp rhs-  return [JsVar (UnQual ident) (thunk body)]+  bind <- bindToplevel (UnQual ident) (thunk body)+  return [bind] +-- | Compile a foreign function. compileFFIFunc :: Type -> Name -> (String,String,String) -> Compile [JsStmt] compileFFIFunc sig ident detail@(_,name,_) = do   let args = zipWith const uniqueNames [1..typeArity sig]   compileFFI sig ident detail (JsRawName name) args args +-- | Compile a foreign method. compileFFIMethod :: Type -> Name -> (String,String,String) -> Compile [JsStmt] compileFFIMethod sig ident detail@(_,name,_) = do   let args = zipWith const uniqueNames [1..typeArity sig]@@ -181,15 +199,16 @@            -> [JsName]            -> Compile [JsStmt] compileFFI sig ident (binding,_,typ) exp params args = do-  return [JsVar (UnQual ident)-                (foldr (\name inner -> JsFun [name] [] (Just inner))-                       (thunk-                        (maybeMonad-                         (unserialize typ-                                      (JsApp exp-                                             (map (\(typ,name) -> serialize typ (JsName name))-                                                  (zip types args))))))-                       params)]+  bind <- bindToplevel (UnQual ident)+                       (foldr (\name inner -> JsFun [name] [] (Just inner))+                              (thunk+                               (maybeMonad+                                (unserialize typ+                                             (JsApp exp+                                                    (map (\(typ,name) -> serialize typ (JsName name))+                                                         (zip types args))))))+                              params)+  return [bind]    where (maybeMonad,types) | binding == "foreignFay"       = (monad,funcTypes)                            | binding == "foreignMethodFay" = (monad,drop 1 funcTypes)@@ -239,6 +258,7 @@     TyParen st     -> typeArity st     _              -> 0 +-- | Compile a data declaration. compileDataDecl :: Decl -> [QualConDecl] -> Compile [JsStmt] compileDataDecl decl constructors = do   fmap concat $@@ -266,36 +286,42 @@           fmap concat $             forM fields $ \(i,field) ->               forM field $ \name ->-                return (JsVar (UnQual name)-                              (JsFun ["x"]-                                     []-                                     (Just (thunk (JsIndex i (force (JsName "x")))))))+                bindToplevel (UnQual name)+                             (JsFun ["x"]+                                    []+                                    (Just (thunk (JsIndex i (force (JsName "x")))))) +-- | Extract the string from a qname.+qname :: QName -> String qname (UnQual (Ident str)) = str-qname _ = error "qname: Expected unqualified ident."+qname _ = error "qname: Expected unqualified ident." -- FIXME: +-- | Extra the string from an ident.+unname :: Name -> String unname (Ident str) = str+unname _ = error "Expected ident from uname." -- FIXME:  -- | Compile a function which pattern matches (causing a case analysis). compileFunCase :: [Match] -> Compile [JsStmt] compileFunCase [] = return [] compileFunCase matches@(Match _ name argslen _ _ _:_) = do-  tco <- asks configTCO+  tco <- config configTCO   pats <- fmap optimizePatConditions $ forM matches $ \match@(Match _ _ pats _ rhs wheres) -> do-    unless (noBinds wheres) $ do throwError (UnsupportedWhereInMatch match) -- TODO: Support `where'.+    unless (noBinds wheres) $ do _ <- throwError (UnsupportedWhereInMatch match) -- TODO: Support `where'.                                  return ()     exp <- compileRhs rhs     foldM (\inner (arg,pat) -> do              compilePat (JsName arg) pat inner)           [JsEarlyReturn exp]           (zip args pats)-  return [JsVar (UnQual name)-                (foldr (\arg inner -> JsFun [arg] [] (Just inner))-                       (stmtsThunk (let stmts = (concat pats ++ basecase)-                                    in if tco-                                          then optimizeTailCalls args name stmts-                                          else stmts))-                       args)]+  bind <- bindToplevel (UnQual name)+                       (foldr (\arg inner -> JsFun [arg] [] (Just inner))+                              (stmtsThunk (let stmts = (concat pats ++ basecase)+                                           in if tco+                                                 then optimizeTailCalls args name stmts+                                                 else stmts))+                              args)+  return [bind]   where args = zipWith const uniqueNames argslen         basecase = if any isWildCardMatch matches                       then []@@ -314,7 +340,7 @@ optimizeTailCalls params name stmts = abandonIfNoChange $   JsWhile (JsLit (JsBool True))           (concatMap replaceTailStmt-                     (reverse (zip (reverse stmts) [0..])))+                     (reverse (zip (reverse stmts) [0::Integer ..])))      where replaceTailStmt (JsIf cond sothen orelse,i) = [JsIf cond (concatMap (replaceTailStmt . (,i)) sothen)                                                                  (concatMap (replaceTailStmt . (,i)) orelse)]@@ -322,23 +348,26 @@         replaceTailStmt (x,_) = [x]         expTailReplace i (flatten -> Just (JsName (UnQual call):args@(_:_)))           | call == name = updateParamsInstead i args-        expTailReplace i original = [JsEarlyReturn original]+        expTailReplace _i original = [JsEarlyReturn original]         updateParamsInstead i args = zipWith JsUpdate params args ++                                      [JsContinue | i /= 0]-        abandonIfNoChange new@(JsWhile _ newstmts)+        abandonIfNoChange (JsWhile _ newstmts)           | newstmts == stmts = stmts-          | otherwise         = [new]+        abandonIfNoChange new = [new] +-- | Flatten an application expression into function : arg : arg : [] flatten :: JsExp -> Maybe [JsExp] flatten (JsApp op@JsApp{} arg) = do   inner <- expand op   return (inner ++ arg) flatten name@JsName{} = return [name]-flatten x = Nothing+flatten _ = Nothing +-- | Expand a forced value into the value.+expand :: JsExp -> Maybe [JsExp] expand (JsApp (JsName (UnQual (Ident "_"))) xs) = do   fmap concat (mapM flatten xs)-expand x = Nothing+expand _ = Nothing  -- -- | Run a JS file. -- prettyPrintFile :: String -> IO String@@ -356,10 +385,11 @@     (Match _ name args Nothing (UnGuardedRhs rhs) _) -> do       body <- compileExp rhs       args <- mapM patToArg args-      return [JsVar (UnQual name)-                    (foldr (\arg inner -> JsFun [arg] [] (Just inner))-                           (thunk body)-                           args)]+      bind <- bindToplevel (UnQual name)+                           (foldr (\arg inner -> JsFun [arg] [] (Just inner))+                                  (thunk body)+                                  args)+      return [bind]     match -> throwError (UnsupportedMatchSyntax match)    where patToArg (PVar name) = return (UnQual name)@@ -400,23 +430,17 @@  instance CompilesTo Exp JsExp where compileTo = compileExp +-- | Compile simple application. compileApp :: Exp -> Exp -> Compile JsExp-compileApp exp1 exp2 = fmap optimizeApp $+compileApp exp1 exp2 =    JsApp <$> (forceFlatName <$> compileExp exp1)         <*> fmap return (compileExp exp2)   where forceFlatName name = JsApp (JsName "_") [name] -optimizeApp :: JsExp -> JsExp-optimizeApp exp =-  case exp of-    exp -> exp-      -  where name JsName{} = True-        name _        = False-+-- | Compile an infix application, optimizing the JS cases. compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp compileInfixApp exp1 op exp2 = do-  config <- ask+  config <- config id   case getOp op of     UnQual (Symbol symbol)       | symbol `elem` words "* + - / < > || &&" -> do@@ -430,17 +454,20 @@   where getOp (QVarOp op) = op         getOp (QConOp op) = op   +-- | Compile a list expression. compileList :: [Exp] -> Compile JsExp compileList xs = do   exps <- mapM compileExp xs   return (JsApp (JsName (hjIdent "list")) [JsList exps]) +-- | Compile an if. compileIf :: Exp -> Exp -> Exp -> Compile JsExp compileIf cond conseq alt =   JsTernaryIf <$> fmap force (compileExp cond)               <*> compileExp conseq               <*> compileExp alt +-- | Compile a lambda. compileLambda :: [Pat] -> Exp -> Compile JsExp compileLambda pats exp = do   exp <- compileExp exp@@ -456,6 +483,7 @@   where unhandledcase = throw "unhandled case" . JsName         allfree = all isWildCardPat pats +-- | Compile case expressions. compileCase :: Exp -> [Alt] -> Compile JsExp compileCase exp alts = do   exp <- compileExp exp@@ -468,11 +496,13 @@                       else Just (throwExp "unhandled case" (JsName (tmpName exp)))))            [exp]) +-- | Compile a do block. compileDoBlock :: [Stmt] -> Compile JsExp compileDoBlock stmts = do   doblock <- foldM compileStmt Nothing (reverse stmts)   maybe (throwError EmptyDoBlock) compileExp doblock +-- | Compile a statement of a do block. compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp) compileStmt inner stmt =   case inner of@@ -520,6 +550,7 @@     PTuple pats     -> compilePList pats body exp     pat             -> throwError (UnsupportedPattern pat) +-- | Compile a literal value from a pattern match. compilePLit :: JsExp -> Literal -> [JsStmt] -> Compile [JsStmt] compilePLit exp literal body = do   lit <- compileLit literal@@ -527,6 +558,8 @@                body                []] +-- | Equality test for two expressions, with some optimizations.+equalExps :: JsExp -> JsExp -> JsExp equalExps a b    | isConstant a && isConstant b = JsEq a b   | isConstant a = JsEq a (force b)@@ -534,9 +567,12 @@   | otherwise =      JsApp (JsName (hjIdent "equal")) [a,b] +-- | Is a JS expression a literal (constant)?+isConstant :: JsExp -> Bool isConstant JsLit{} = True isConstant _       = False +-- | Compile a pattern application. compilePApp :: QName -> [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] compilePApp cons pats exp body = do   let forcedExp = force exp@@ -556,6 +592,7 @@                substmts                []] +-- | Compile a pattern list. compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt] compilePList [] body exp =   return [JsIf (JsEq (force exp) JsNull) body []]@@ -569,6 +606,7 @@                     (reverse (zip [0..] pats))   return substmts +-- | Compile an infix pattern (e.g. cons and tuples.) compileInfixPat :: JsExp -> Pat -> [JsStmt] -> Compile [JsStmt] compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =   case cons of@@ -630,12 +668,6 @@               zipWith (:) (cycle "v")                           (map show [1 :: Integer ..]) -thenm :: JsExp -> JsExp -> JsExp-thenm e inner =-  JsApp (JsApp (JsName (hjIdent "then"))-               [e])-        [inner]- -- | Optimize pattern matching conditions by merging conditions in common. optimizePatConditions :: [[JsStmt]] -> [[JsStmt]] optimizePatConditions = concat . map merge . groupBy sameIf where@@ -708,7 +740,7 @@   | otherwise = JsApp (JsName "_") [exp]  -- | Force an expression in a thunk.-forceInlinable :: Config -> JsExp -> JsExp+forceInlinable :: CompileConfig -> JsExp -> JsExp forceInlinable config exp   | isConstant exp = exp   | configInlineForce config =@@ -747,6 +779,21 @@ hjIdent :: String -> QName hjIdent = Qual (ModuleName "Fay") . Ident +-- | Make a top-level binding.+bindToplevel :: QName -> JsExp -> Compile JsStmt+bindToplevel name exp = do+  exportAll <- gets stateExportAll+  when exportAll $ emitExport (EVar name)+  return (JsVar name exp)++-- | Emit exported names.+emitExport :: ExportSpec -> Compile ()+emitExport spec = +  case spec of+    EVar (UnQual name) -> modify $ \s -> s { stateExports = name : stateExports s }+    EVar _             -> error "Emitted a qualifed export, not supported."+    _ -> throwError (UnsupportedExportSpec spec)+ -------------------------------------------------------------------------------- -- Utilities @@ -756,3 +803,7 @@   case result of     ParseOk a -> ok a     ParseFailed srcloc msg -> fail (srcloc,msg)++-- | Get a config option.+config :: (CompileConfig -> a) -> Compile a+config f = gets (f . stateConfig)

@@ -1,13 +1,15 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-} module Language.Fay.Compiler where  import Control.Exception  (throw) import Language.Fay (compileViaStr,compileModule) import Language.Fay.Types+import Language.Haskell.Exts.Syntax import Paths_fay  -- | Compile file program to…-compileFromTo :: Config -> Bool -> FilePath -> FilePath -> IO ()+compileFromTo :: CompileConfig -> Bool -> FilePath -> FilePath -> IO () compileFromTo config autorun filein fileout = do   runtime <- getDataFileName "js/runtime.js"   stdlibpath <- getDataFileName "hs/stdlib.hs"@@ -29,28 +31,41 @@  -- | Compile the given module to a runnable program. compileProgram :: (Show from,Show to,CompilesTo from to)-               => Config -> Bool -> String -> (from -> Compile to) -> String+               => CompileConfig -> Bool -> String -> (from -> Compile to) -> String                -> IO (Either CompileError String) compileProgram config autorun raw with hscode = do   result <- compileViaStr config with hscode   case result of     Left err -> return (Left err)-    Right jscode -> return (Right (unlines ["var Fay = function(){"-                                           ,raw-                                           ,jscode-                                           ,"return {"-                                           ,"  force:_,"-                                           ,"  thunk:$,"-                                           ,"  list:Fay$$list,"-                                           ,"  encodeShow:Fay$$encodeShow,"-                                           ,"  main:main,"-                                           ,"  eval:Fay$$eval"-                                           ,"  };"-                                           ,"};"-                                           ,if autorun-                                               then ";\nvar fay = new Fay();fay.force(fay.main);"-                                               else ""-                                           ]))+    Right (jscode,state) -> do+      let (ModuleName modulename) = stateModuleName state+          exports                 = stateExports state+      return (Right (unlines ["var " ++ modulename ++ " = function(){"+                             ,raw+                             ,jscode+                             ,"// Exports"+                             ,unlines (map printExport exports)+                             ,"// Built-ins"+                             ,"this.$force      = _;"+                             ,"this.$           = $;"+                             ,"this.$list       = Fay$$list;"+                             ,"this.$encodeShow = Fay$$encodeShow;"+                             ,"this.$eval       = Fay$$eval;"+                             ,"};"+                             ,if autorun+                                 then unlines [";"+                                              ,"var main = new " ++ modulename ++ "();"+                                              ,"main.$force(main.main);"+                                              ]+                                 else ""+                             ]))++-- | Print an this.x = x; export out.+printExport :: Name -> String+printExport name =+  printJS (JsSetProp "this"+                     (UnQual name)+                     (JsName (UnQual name)))  -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String

@@ -81,6 +81,8 @@     (unwords ["var",printJS name,"=",printJS expr ++ ";"])   printJS (JsUpdate name expr) =     (unwords [printJS name,"=",printJS expr ++ ";"])+  printJS (JsSetProp name prop expr) =+    (concat [printJS name,".",printJS prop," = ",printJS expr ++ ";"])   printJS (JsIf exp thens elses) =     concat       [("if (" ++ printJS exp ++ ") {")

@@ -12,17 +12,19 @@   ,JsParam   ,JsName   ,CompileError(..)-  ,Compile+  ,Compile(..)   ,CompilesTo(..)   ,Printable(..)   ,Fay-  ,Config(..))+  ,CompileConfig(..)+  ,CompileState(..))   where  import Control.Exception-import Control.Monad.Error (Error,ErrorT)+import Control.Applicative+import Control.Monad.Error (Error,ErrorT,MonadError) import Control.Monad.Identity (Identity)-import Control.Monad.Reader+import Control.Monad.State import Data.Data import Data.Default import Language.Haskell.Exts@@ -30,17 +32,33 @@ -------------------------------------------------------------------------------- -- Compiler types -data Config = Config+-- | Configuration of the compiler.+data CompileConfig = CompileConfig   { configTCO         :: Bool   , configInlineForce :: Bool   } deriving (Show) -instance Default Config where-  def = Config False False+-- | Default configuration.+instance Default CompileConfig where+  def = CompileConfig False False --- | Convenience/doc type.-type Compile = ReaderT Config (ErrorT CompileError IO)+-- | State of the compiler.+data CompileState = CompileState+  { stateConfig     :: CompileConfig+  , stateExports    :: [Name]+  , stateExportAll  :: Bool+  , stateModuleName :: ModuleName+  } deriving (Show) +-- | Compile monad.+newtype Compile a = Compile { unCompile :: StateT CompileState (ErrorT CompileError IO) a }+  deriving (MonadState CompileState+           ,MonadError CompileError+           ,MonadIO+           ,Monad+           ,Functor+           ,Applicative)+ -- | Convenience type for function parameters. type JsParam = JsName @@ -60,6 +78,7 @@ data CompileError   = ParseError SrcLoc String   | UnsupportedDeclaration Decl+  | UnsupportedExportSpec ExportSpec   | UnsupportedMatchSyntax Match   | UnsupportedWhereInMatch Match   | UnsupportedExpression Exp@@ -94,6 +113,7 @@   | JsThrow JsExp   | JsWhile JsExp [JsStmt]   | JsUpdate JsName JsExp+  | JsSetProp JsName JsName JsExp   | JsContinue   deriving (Show,Eq)