diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs index dc3b9d5..e247612 100644 --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -2,14 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-} --- | Compile expressions +-- | Compile expressions. module Fay.Compiler.Exp where import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.Print -import Fay.Compiler.FFI (ffiFun) +import Fay.Compiler.FFI (compileFFIExp) import Fay.Types import Control.Applicative @@ -46,12 +46,12 @@ compileExp exp = EnumFromThen a b -> compileEnumFromThen a b EnumFromThenTo a b z -> compileEnumFromThenTo a b z RecConstr name fieldUpdates -> compileRecConstr name fieldUpdates - RecUpdate rec fieldUpdates -> updateRec rec fieldUpdates + RecUpdate rec fieldUpdates -> compileRecUpdate rec fieldUpdates ListComp exp stmts -> compileExp =<< desugarListComp exp stmts ExpTypeSig srcloc exp sig -> case ffiExp exp of Nothing -> compileExp exp - Just formatstr -> ffiFun srcloc Nothing formatstr sig + Just formatstr -> compileFFIExp srcloc Nothing formatstr sig exp -> throwError (UnsupportedExpression exp) @@ -86,6 +86,7 @@ compileApp exp1@(Var q) exp2 = compileApp exp1 exp2 = compileApp' exp1 exp2 +-- | Helper for compileApp. compileApp' :: Exp -> Exp -> Compile JsExp compileApp' exp1 exp2 = do flattenApps <- config configFlattenApps @@ -308,8 +309,9 @@ compileRecConstr name fieldUpdates = do -- I couldn't find a code that generates (FieldUpdate (FieldPun ..)) updateStmt _ u = error ("updateStmt: " ++ show u) -updateRec :: Exp -> [FieldUpdate] -> Compile JsExp -updateRec rec fieldUpdates = do +-- | Compile a record update. +compileRecUpdate :: Exp -> [FieldUpdate] -> Compile JsExp +compileRecUpdate rec fieldUpdates = do record <- force <$> compileExp rec let copyName = UnQual (Ident "$_record_to_update") copy = JsVar (JsNameVar copyName) diff --git a/src/Fay/Compiler/FFI.hs b/src/Fay/Compiler/FFI.hs index a386297..ba08dca 100644 --- a/src/Fay/Compiler/FFI.hs +++ b/src/Fay/Compiler/FFI.hs @@ -3,13 +3,13 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wall #-} --- | Compiling the FFI support. +-- | Compile FFI definitions. module Fay.Compiler.FFI (emitFayToJs ,emitJsToFay ,compileFFI - ,ffiFun + ,compileFFIExp ,jsToFayHash ,fayToJsHash ) where @@ -43,7 +43,7 @@ compileFFI :: SrcLoc -- ^ Location of the original FFI decl. compileFFI srcloc name formatstr sig = -- substitute newtypes with their child types before calling -- real compileFFI - compileFFI' srcloc name formatstr =<< rmNewtys sig + compileFFI' =<< rmNewtys sig where rmNewtys :: Type -> Compile Type rmNewtys (TyForall b c t) = TyForall b c <$> rmNewtys t @@ -61,14 +61,15 @@ compileFFI srcloc name formatstr sig = rmNewtys (TyInfix t1 q t2)= flip TyInfix q <$> rmNewtys t1 <*> rmNewtys t2 rmNewtys (TyKind t k) = flip TyKind k <$> rmNewtys t -compileFFI' :: SrcLoc -> Name -> String -> Type -> Compile [JsStmt] -compileFFI' srcloc name formatstr sig = do - fun <- ffiFun srcloc (Just name) formatstr sig - stmt <- bindToplevel True name fun - return [stmt] + compileFFI' :: Type -> Compile [JsStmt] + compileFFI' sig' = do + fun <- compileFFIExp srcloc (Just name) formatstr sig' + stmt <- bindToplevel True name fun + return [stmt] -ffiFun :: SrcLoc -> Maybe Name -> String -> Type -> Compile JsExp -ffiFun srcloc nameopt formatstr sig = do +-- | Compile an FFI expression (also used when compiling top level definitions). +compileFFIExp :: SrcLoc -> Maybe Name -> String -> Type -> Compile JsExp +compileFFIExp srcloc nameopt formatstr sig = do let name = fromMaybe "" nameopt inner <- formatFFI srcloc formatstr (zip params funcFundamentalTypes) case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of @@ -336,13 +337,14 @@ formatFFI srcloc formatstr args = go formatstr where explodeFields :: [([a], t)] -> [(a, t)] explodeFields = concatMap $ \(names,typ) -> map (,typ) names +-- | Generate Fay→JS encoding. fayToJsHash :: [(String, JsExp)] -> [JsStmt] fayToJsHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "fayToJsHash", JsObj cases]] +-- | Generate JS→Fay decoding. jsToFayHash :: [(String, JsExp)] -> [JsStmt] jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]] - -- | Make a JS→Fay decoder. emitJsToFay :: Name -> [TyVarBind] -> [([Name], BangType)] -> Compile () emitJsToFay name tyvars (explodeFields -> fieldTypes) = do diff --git a/src/Fay/Compiler/GADT.hs b/src/Fay/Compiler/GADT.hs index b45c39f..5036467 100644 --- a/src/Fay/Compiler/GADT.hs +++ b/src/Fay/Compiler/GADT.hs @@ -1,4 +1,8 @@ -module Fay.Compiler.GADT(convertGADT) where +-- | Convert GADTs into normal data types. + +module Fay.Compiler.GADT + (convertGADT + ) where import Language.Haskell.Exts hiding (name, binds) diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs index 78991c7..299f8d4 100644 --- a/src/Fay/Compiler/InitialPass.hs +++ b/src/Fay/Compiler/InitialPass.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Preprocessing collecting names, data types, newtypes, imports, and exports +-- for all modules recursively. module Fay.Compiler.InitialPass (initialPass ) where @@ -22,7 +24,7 @@ import Language.Haskell.Exts.Parser import Language.Haskell.Exts.Syntax import Prelude hiding (mod, read) - +-- | Preprocess and collect all information needed during code generation. initialPass :: Module -> Compile () initialPass (Module _ mod _ Nothing exports imports decls) = withModuleScope $ do diff --git a/src/Fay/Compiler/ModuleScope.hs b/src/Fay/Compiler/ModuleScope.hs index a83e522..be87f20 100644 --- a/src/Fay/Compiler/ModuleScope.hs +++ b/src/Fay/Compiler/ModuleScope.hs @@ -110,6 +110,7 @@ envPrimOpsMap = M.fromList , (Symbol "||", Qual (ModuleName "Fay$") (Ident "or")) ] +-- | Lookup a primop that was resolved to a Prelude definition. findPrimOp :: QName -> Maybe QName findPrimOp (Qual (ModuleName "Prelude") s) = M.lookup s envPrimOpsMap findPrimOp _ = Nothing diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs index 27b5ced..411bfbf 100644 --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -101,6 +101,7 @@ compilePAsPat exp name pat body = do p <- compilePat exp pat body return $ JsVar (JsNameVar $ UnQual name) exp : p +-- | Compile a pattern match on a newtype. compileNewtypePat :: [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] compileNewtypePat [pat] exp body = compilePat exp pat body compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs index 3fcdb57..35ca5e5 100644 --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -130,6 +130,7 @@ instance Printable JsStmt where printJS (JsMappedVar _ name expr) = "var " +> name +> " = " +> expr +> ";" +> newline +-- | Print a module path. instance Printable ModulePath where printJS (unModulePath -> l) = write $ intercalate "." l @@ -205,12 +206,12 @@ instance Printable JsExp where printJS (JsOr a b) = printJS a +> "||" +> printJS b +-- | Unqualify a JsName. ident :: JsName -> JsName ident n = case n of JsConstructor (Qual _ s) -> JsNameVar $ UnQual s a -> a - -- | Print one of the kinds of names. instance Printable JsName where printJS name = @@ -227,11 +228,13 @@ instance Printable JsName where JsParametrizedType -> write "type" JsModuleName (ModuleName m) -> write m +-- | Print a constructor name given a QName. printCons :: QName -> Printer () printCons (UnQual n) = printConsName n printCons (Qual (ModuleName m) n) = printJS m +> "." +> printConsName n printCons (Special _) = error "qname2String Special" +-- | Print a constructor name given a Name. Helper for printCons. printConsName :: Name -> Printer () printConsName n = write "_" >> printJS n diff --git a/src/Fay/Compiler/QName.hs b/src/Fay/Compiler/QName.hs index c0a3044..fbe91ec 100644 --- a/src/Fay/Compiler/QName.hs +++ b/src/Fay/Compiler/QName.hs @@ -1,3 +1,5 @@ +-- | Extras for haskell-src-exts names. + module Fay.Compiler.QName where import Language.Haskell.Exts.Syntax diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs index 5a5da3c..a24ec91 100644 --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -88,12 +88,16 @@ data CompileConfig = CompileConfig , configBasePath :: Maybe FilePath -- ^ Custom source location for fay-base } deriving (Show) +-- | The name of a module split into a list for code generation. newtype ModulePath = ModulePath { unModulePath :: [String] } deriving (Eq, Ord, Show) +-- | Construct the complete ModulePath from a ModuleName. mkModulePath :: ModuleName -> ModulePath mkModulePath (ModuleName m) = ModulePath . splitOn "." $ m +-- | Construct intermediate module paths from a ModuleName. +-- mkModulePaths "A.B" => [["A"], ["A","B"]] mkModulePaths :: ModuleName -> [ModulePath] mkModulePaths (ModuleName m) = map ModulePath . tail . inits . splitOn "." $ m @@ -143,9 +147,11 @@ data CompileReader = CompileReader faySourceDir :: IO FilePath faySourceDir = fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs") +-- | Add a ModulePath to CompileState, meaning it has been printed. addModulePath :: ModulePath -> CompileState -> CompileState addModulePath mp cs = cs { stateJsModulePaths = mp `S.insert` stateJsModulePaths cs } +-- | Has this ModulePath been added/printed? addedModulePath :: ModulePath -> CompileState -> Bool addedModulePath mp CompileState{..} = mp `S.member` stateJsModulePaths @@ -158,13 +164,15 @@ addCurrentExport q cs = qnames = maybe (S.singleton q) (S.insert q) $ M.lookup (stateModuleName cs) (_stateExports cs) --- | Get all of the exported identifiers for the current module. +-- | Get all exports for the current module. getCurrentExports :: CompileState -> Set QName getCurrentExports cs = getExportsFor (stateModuleName cs) cs +-- | Get exports from the current module originating from other modules. getNonLocalExports :: CompileState -> Set QName getNonLocalExports st = S.filter ((/= Just (stateModuleName st)) . qModName) . getCurrentExportsWithoutNewtypes $ st +-- | Get all exports from the current module except newtypes. getCurrentExportsWithoutNewtypes :: CompileState -> Set QName getCurrentExportsWithoutNewtypes cs = excludeNewtypes cs $ getCurrentExports cs where diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs index 40bc906..52ad965 100644 --- a/src/System/Directory/Extra.hs +++ b/src/System/Directory/Extra.hs @@ -1,10 +1,11 @@ - +-- | Extra directory functions. module System.Directory.Extra where import Control.Monad (forM) import System.Directory (doesDirectoryExist, getDirectoryContents) import System.FilePath (()) +-- | Get all files in a folder and its subdirectories. -- Taken from Real World Haskell -- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html getRecursiveContents :: FilePath -> IO [FilePath] diff --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs index a83fa3e..24aa145 100644 --- a/src/System/Process/Extra.hs +++ b/src/System/Process/Extra.hs @@ -5,6 +5,7 @@ module System.Process.Extra where import System.Exit import System.Process +-- | Read from a process returning both std err and out. readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) readAllFromProcess program flags input = do (code,out,err) <- readProcessWithExitCode program flags input