module Language.Fay.Types
(JsStmt(..)
,JsExp(..)
,JsLit(..)
,JsName(..)
,CompileError(..)
,Compile(..)
,CompilesTo(..)
,Printable(..)
,Fay
,CompileReader(..)
,CompileConfig(
configFlattenApps
,configOptimize
,configGClosure
,configExportBuiltins
,configPrettyPrint
,configHtmlWrapper
,configHtmlJSLibs
,configLibrary
,configWarn
,configFilePath
,configTypecheck
,configWall
,configPackageConf
)
,configDirectoryIncludes
,addConfigDirectoryInclude
,addConfigDirectoryIncludes
,configPackages
,addConfigPackage
,addConfigPackages
,CompileState(..)
,defaultCompileState
,defaultCompileReader
,faySourceDir
,FundamentalType(..)
,PrintState(..)
,Printer(..)
,Mapping(..)
,SerializeContext(..))
where
import Control.Applicative
import Control.Monad.Error (Error, ErrorT, MonadError)
import Control.Monad.Identity (Identity)
import Control.Monad.State
import Control.Monad.RWS
import Data.Default
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.String
import Language.Haskell.Exts
import System.FilePath
import Language.Fay.ModuleScope (ModuleScope)
import Paths_fay
data CompileConfig = CompileConfig
{ configOptimize :: Bool
, configFlattenApps :: Bool
, configExportBuiltins :: Bool
, _configDirectoryIncludes :: [FilePath]
, configPrettyPrint :: Bool
, configHtmlWrapper :: Bool
, configHtmlJSLibs :: [FilePath]
, configLibrary :: Bool
, configWarn :: Bool
, configFilePath :: Maybe FilePath
, configTypecheck :: Bool
, configWall :: Bool
, configGClosure :: Bool
, configPackageConf :: Maybe FilePath
, _configPackages :: [String]
} deriving (Show)
instance Default CompileConfig where
def =
addConfigPackage "fay-base" $
CompileConfig False False True [] False False [] False True Nothing True False False Nothing []
configDirectoryIncludes :: CompileConfig -> [FilePath]
configDirectoryIncludes = _configDirectoryIncludes
addConfigDirectoryInclude :: FilePath -> CompileConfig -> CompileConfig
addConfigDirectoryInclude fp cfg = cfg { _configDirectoryIncludes = fp : _configDirectoryIncludes cfg }
addConfigDirectoryIncludes :: [FilePath] -> CompileConfig -> CompileConfig
addConfigDirectoryIncludes fps cfg = foldl (flip addConfigDirectoryInclude) cfg fps
configPackages :: CompileConfig -> [String]
configPackages = _configPackages
addConfigPackage :: String -> CompileConfig -> CompileConfig
addConfigPackage pkg cfg = cfg { _configPackages = pkg : _configPackages cfg }
addConfigPackages :: [String] -> CompileConfig -> CompileConfig
addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps
data CompileState = CompileState
{ stateExports :: [QName]
, stateExportsCache :: Map ModuleName [QName]
, stateModuleName :: ModuleName
, stateFilePath :: FilePath
, stateRecordTypes :: [(QName,[QName])]
, stateRecords :: [(QName,[QName])]
, stateFayToJs :: [JsStmt]
, stateJsToFay :: [JsStmt]
, stateImported :: [(ModuleName,FilePath)]
, stateNameDepth :: Integer
, stateLocalScope :: Set Name
, stateModuleScope :: ModuleScope
} deriving (Show)
data CompileReader = CompileReader
{ readerConfig :: CompileConfig
} deriving (Show)
faySourceDir :: IO FilePath
faySourceDir = fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")
defaultCompileReader :: CompileConfig -> IO CompileReader
defaultCompileReader config = do
srcdir <- faySourceDir
return CompileReader
{ readerConfig = addConfigDirectoryInclude srcdir config
}
defaultCompileState :: IO CompileState
defaultCompileState = do
types <- getDataFileName "src/Language/Fay/Types.hs"
return $ CompileState {
stateExports = []
, stateExportsCache = M.empty
, stateModuleName = ModuleName "Main"
, stateRecordTypes = []
, stateRecords = []
, stateFayToJs = []
, stateJsToFay = []
, stateImported = [("Language.Fay.Types",types)]
, stateNameDepth = 1
, stateFilePath = "<unknown>"
, stateLocalScope = S.empty
, stateModuleScope = def
}
newtype Compile a = Compile
{ unCompile :: RWST CompileReader
()
CompileState (ErrorT CompileError IO)
a
}
deriving (MonadState CompileState
,MonadError CompileError
,MonadReader CompileReader
,MonadIO
,Monad
,Functor
,Applicative)
class (Parseable from,Printable to) => CompilesTo from to | from -> to where
compileTo :: from -> Compile to
data Mapping = Mapping
{ mappingName :: String
, mappingFrom :: SrcLoc
, mappingTo :: SrcLoc
} deriving (Show)
data PrintState = PrintState
{ psPretty :: Bool
, psLine :: Int
, psColumn :: Int
, psMapping :: [Mapping]
, psIndentLevel :: Int
, psOutput :: [String]
, psNewline :: Bool
}
instance Default PrintState where
def = PrintState False 0 0 [] 0 [] False
newtype Printer a = Printer { runPrinter :: State PrintState a }
deriving (Monad,Functor,MonadState PrintState)
class Printable a where
printJS :: a -> Printer ()
data CompileError
= ParseError SrcLoc String
| UnsupportedDeclaration Decl
| UnsupportedExportSpec ExportSpec
| UnsupportedMatchSyntax Match
| UnsupportedWhereInMatch Match
| UnsupportedExpression Exp
| UnsupportedLiteral Literal
| UnsupportedLetBinding Decl
| UnsupportedOperator QOp
| UnsupportedPattern Pat
| UnsupportedFieldPattern PatField
| UnsupportedRhs Rhs
| UnsupportedGuardedAlts GuardedAlts
| UnsupportedWhereInAlt Alt
| UnsupportedImport ImportDecl
| UnsupportedQualStmt QualStmt
| EmptyDoBlock
| UnsupportedModuleSyntax Module
| LetUnsupported
| InvalidDoBlock
| RecursiveDoUnsupported
| Couldn'tFindImport ModuleName [FilePath]
| FfiNeedsTypeSig Decl
| FfiFormatBadChars String
| FfiFormatNoSuchArg Int
| FfiFormatIncompleteArg
| FfiFormatInvalidJavaScript SrcLoc String String
| UnableResolveUnqualified Name
| UnableResolveQualified QName
| UnableResolveCachedImport ModuleName
deriving (Show)
instance Error CompileError
newtype Fay a = Fay (Identity a)
deriving Monad
data JsStmt
= JsVar JsName JsExp
| JsMappedVar SrcLoc JsName JsExp
| JsIf JsExp [JsStmt] [JsStmt]
| JsEarlyReturn JsExp
| JsThrow JsExp
| JsWhile JsExp [JsStmt]
| JsUpdate JsName JsExp
| JsSetProp JsName JsName JsExp
| JsSetPropExtern JsName JsName JsExp
| JsContinue
| JsBlock [JsStmt]
deriving (Show,Eq)
data JsExp
= JsName JsName
| JsRawExp String
| JsFun [JsName] [JsStmt] (Maybe JsExp)
| JsLit JsLit
| JsApp JsExp [JsExp]
| JsNegApp JsExp
| JsTernaryIf JsExp JsExp JsExp
| JsNull
| JsParen JsExp
| JsGetProp JsExp JsName
| JsLookup JsExp JsExp
| JsUpdateProp JsExp JsName JsExp
| JsGetPropExtern JsExp String
| JsUpdatePropExtern JsExp JsName JsExp
| JsList [JsExp]
| JsNew JsName [JsExp]
| JsThrowExp JsExp
| JsInstanceOf JsExp JsName
| JsIndex Int JsExp
| JsEq JsExp JsExp
| JsNeq JsExp JsExp
| JsInfix String JsExp JsExp
| JsObj [(String,JsExp)]
| JsUndefined
deriving (Show,Eq)
data JsName
= JsNameVar QName
| JsThis
| JsParametrizedType
| JsThunk
| JsForce
| JsApply
| JsParam Integer
| JsTmp Integer
| JsConstructor QName
| JsBuiltIn Name
deriving (Eq,Show)
data JsLit
= JsChar Char
| JsStr String
| JsInt Int
| JsFloating Double
| JsBool Bool
deriving (Show,Eq)
data FundamentalType
= FunctionType [FundamentalType]
| JsType FundamentalType
| ListType FundamentalType
| TupleType [FundamentalType]
| UserDefined Name [FundamentalType]
| Defined FundamentalType
| Nullable FundamentalType
| DateType
| StringType
| DoubleType
| IntType
| BoolType
| PtrType
| Automatic
| UnknownType
deriving (Show)
instance IsString Name where
fromString = Ident
instance IsString QName where
fromString = UnQual . Ident
instance IsString ModuleName where
fromString = ModuleName
data SerializeContext = SerializeAnywhere | SerializeUserArg Int
deriving (Read,Show,Eq)