module Fay.Types
(JsStmt(..)
,JsExp(..)
,JsLit(..)
,JsName(..)
,CompileError(..)
,Compile(..)
,CompilesTo(..)
,Printable(..)
,Fay
,CompileReader(..)
,CompileWriter(..)
,CompileConfig(..)
,CompileState(..)
,addCurrentExport
,getCurrentExports
,getExportsFor
,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.Maybe
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 Fay.Compiler.ModuleScope (ModuleScope)
import Paths_fay
data CompileConfig = CompileConfig
{ configOptimize :: Bool
, configFlattenApps :: Bool
, configExportBuiltins :: Bool
, configExportRuntime :: Bool
, configExportStdlib :: Bool
, configExportStdlibOnly :: Bool
, configDispatchers :: Bool
, configDispatcherOnly :: Bool
, configNaked :: Bool
, configDirectoryIncludes :: [(Maybe String, 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]
, configBasePath :: Maybe FilePath
} deriving (Show)
data CompileState = CompileState
{ _stateExports :: Map ModuleName (Set QName)
, stateRecordTypes :: [(QName,[QName])]
, stateRecords :: [(QName,[QName])]
, stateNewtypes :: [(QName, Maybe QName, Type)]
, stateImported :: [(ModuleName,FilePath)]
, stateNameDepth :: Integer
, stateLocalScope :: Set Name
, stateModuleScope :: ModuleScope
, stateModuleName :: ModuleName
} deriving (Show)
data CompileWriter = CompileWriter
{ writerCons :: [JsStmt]
, writerFayToJs :: [JsStmt]
, writerJsToFay :: [JsStmt]
}
deriving (Show)
instance Monoid CompileWriter where
mempty = CompileWriter [] [] []
mappend (CompileWriter a b c) (CompileWriter x y z) =
CompileWriter (a++x) (b++y) (c++z)
data CompileReader = CompileReader
{ readerConfig :: CompileConfig
, readerCompileLit :: Literal -> Compile JsExp
, readerCompileDecls :: Bool -> [Decl] -> Compile [JsStmt]
}
faySourceDir :: IO FilePath
faySourceDir = fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")
addCurrentExport :: QName -> CompileState -> CompileState
addCurrentExport q cs =
cs { _stateExports = M.insert (stateModuleName cs) qnames $ _stateExports cs}
where
qnames = maybe (S.singleton q) (S.insert q)
$ M.lookup (stateModuleName cs) (_stateExports cs)
getCurrentExports :: CompileState -> Set QName
getCurrentExports cs = getExportsFor (stateModuleName cs) cs
getExportsFor :: ModuleName -> CompileState -> Set QName
getExportsFor mn cs = excludeNewtypes cs $ fromMaybe S.empty $ M.lookup mn (_stateExports cs)
where
excludeNewtypes :: CompileState -> Set QName -> Set QName
excludeNewtypes cs' names =
let newtypes = stateNewtypes cs'
constrs = map (\(c, _, _) -> c) newtypes
destrs = map (\(_, d, _) -> fromJust d) . filter (\(_, d, _) -> isJust d) $ newtypes
in names `S.difference` (S.fromList constrs `S.union` S.fromList destrs)
newtype Compile a = Compile
{ unCompile :: RWST CompileReader CompileWriter CompileState (ErrorT CompileError IO) a
}
deriving (MonadState CompileState
,MonadError CompileError
,MonadReader CompileReader
,MonadWriter CompileWriter
,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 SrcLoc String
| FfiFormatNoSuchArg SrcLoc Int
| FfiFormatIncompleteArg SrcLoc
| FfiFormatInvalidJavaScript SrcLoc 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
| JsSetPropExtern JsName JsName JsExp
| JsContinue
| JsBlock [JsStmt]
| JsExpStmt JsExp
deriving (Show,Eq)
data JsExp
= JsName JsName
| JsRawExp String
| JsSeq [JsExp]
| 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)
instance IsString JsLit where fromString = JsStr
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)