module Language.Fay.Types
(JsStmt(..)
,JsExp(..)
,JsLit(..)
,JsName(..)
,CompileError(..)
,Compile(..)
,CompilesTo(..)
,Printable(..)
,Fay
,CompileConfig(..)
,CompileState(..)
,defaultCompileState
,FundamentalType(..)
,PrintState(..)
,Printer(..)
,NameScope(..)
,Mapping(..))
where
import Control.Applicative
import Control.Monad.Error (Error, ErrorT, MonadError)
import Control.Monad.Identity (Identity)
import Control.Monad.State
import Data.Default
import Data.Map as M
import Data.String
import Language.Haskell.Exts
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
} deriving (Show)
instance Default CompileConfig where
def = CompileConfig False False True [] False False [] False True Nothing True False
data CompileState = CompileState
{ stateConfig :: CompileConfig
, stateExports :: [QName]
, stateExportAll :: Bool
, stateModuleName :: ModuleName
, stateFilePath :: FilePath
, stateRecords :: [(QName,[QName])]
, stateFayToJs :: [JsStmt]
, stateJsToFay :: [JsStmt]
, stateImported :: [(ModuleName,FilePath)]
, stateNameDepth :: Integer
, stateScope :: Map Name [NameScope]
} deriving (Show)
data NameScope = ScopeImported ModuleName (Maybe Name)
| ScopeImportedAs Bool ModuleName Name
| ScopeBinding
deriving (Show,Eq)
defaultCompileState :: CompileConfig -> IO CompileState
defaultCompileState config = do
ffi <- getDataFileName "src/Language/Fay/Stdlib.hs"
types <- getDataFileName "src/Language/Fay/Types.hs"
prelude <- getDataFileName "src/Language/Fay/Prelude.hs"
return $ CompileState {
stateConfig = config
, stateExports = []
, stateExportAll = True
, stateModuleName = ModuleName "Main"
, stateRecords = [("Nothing",[]),("Just",["slot1"])]
, stateFayToJs = []
, stateJsToFay = []
, stateImported = [("Language.Fay.FFI",ffi),("Language.Fay.Types",types),("Prelude",prelude)]
, stateNameDepth = 1
, stateFilePath = "<unknown>"
, stateScope = M.fromList primOps
}
primOps :: [(Name, [NameScope])]
primOps =
[(Symbol ">>",[ScopeImported "Fay$" (Just "then")])
,(Symbol ">>=",[ScopeImported "Fay$" (Just "bind")])
,(Ident "return",[ScopeImported "Fay$" (Just "return")])
,(Ident "force",[ScopeImported "Fay$" (Just "force")])
,(Ident "seq",[ScopeImported "Fay$" (Just "seq")])
,(Symbol "*",[ScopeImported "Fay$" (Just "mult")])
,(Symbol "+",[ScopeImported "Fay$" (Just "add")])
,(Symbol "-",[ScopeImported "Fay$" (Just "sub")])
,(Symbol "/",[ScopeImported "Fay$" (Just "div")])
,(Symbol "==",[ScopeImported "Fay$" (Just "eq")])
,(Symbol "/=",[ScopeImported "Fay$" (Just "neq")])
,(Symbol ">",[ScopeImported "Fay$" (Just "gt")])
,(Symbol "<",[ScopeImported "Fay$" (Just "lt")])
,(Symbol ">=",[ScopeImported "Fay$" (Just "gte")])
,(Symbol "<=",[ScopeImported "Fay$" (Just "lte")])
,(Symbol "&&",[ScopeImported "Fay$" (Just "and")])
,(Symbol "||",[ScopeImported "Fay$" (Just "or")])]
newtype Compile a = Compile { unCompile :: StateT CompileState (ErrorT CompileError IO) a }
deriving (MonadState CompileState
,MonadError CompileError
,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
| UnsupportedImport ImportDecl
| UnsupportedQualStmt QualStmt
| EmptyDoBlock
| UnsupportedModuleSyntax Module
| LetUnsupported
| InvalidDoBlock
| RecursiveDoUnsupported
| Couldn'tFindImport ModuleName [FilePath]
| FfiNeedsTypeSig Decl
| FfiFormatBadChars String
| FfiFormatNoSuchArg Int
| FfiFormatIncompleteArg
| FfiFormatInvalidJavaScript String String
| UnableResolveUnqualified Name
| UnableResolveQualified QName
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
| 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
| 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
| DateType
| StringType
| DoubleType
| IntType
| BoolType
| UnknownType
deriving (Show)
instance IsString Name where
fromString = Ident
instance IsString QName where
fromString = UnQual . Ident
instance IsString ModuleName where
fromString = ModuleName