module Fay.Types
(JsStmt(..)
,JsExp(..)
,JsLit(..)
,JsName(..)
,CompileError(..)
,Compile(..)
,CompileResult
,CompileModule
,Printable(..)
,Fay
,CompileReader(..)
,CompileWriter(..)
,CompileConfig(..)
,CompileState(..)
,FundamentalType(..)
,PrintState(..)
,Printer(..)
,SerializeContext(..)
,ModulePath (unModulePath)
,mkModulePath
,mkModulePaths
,mkModulePathFromQName
) where
import Fay.Compiler.QName
import qualified Fay.Exts as F
import qualified Fay.Exts.NoAnnotation as N
import qualified Fay.Exts.Scoped as S
import Control.Applicative
import Control.Monad.Error (Error, ErrorT, MonadError)
import Control.Monad.Identity (Identity)
import Control.Monad.RWS
import Control.Monad.State
import Data.Default
import Data.List
import Data.List.Split
import Data.Map (Map)
import Data.Set (Set)
import Data.String
import Distribution.HaskellSuite.Modules
import Language.Haskell.Exts.Annotated
import Language.Haskell.Names (Symbols)
import SourceMap.Types
data CompileConfig = CompileConfig
{ configOptimize :: Bool
, configFlattenApps :: Bool
, configExportRuntime :: Bool
, configExportStdlib :: Bool
, configExportStdlibOnly :: Bool
, configDirectoryIncludes :: [(Maybe String, FilePath)]
, configPrettyPrint :: Bool
, configHtmlWrapper :: Bool
, configSourceMap :: Bool
, configHtmlJSLibs :: [FilePath]
, configLibrary :: Bool
, configWarn :: Bool
, configFilePath :: Maybe FilePath
, configTypecheck :: Bool
, configWall :: Bool
, configGClosure :: Bool
, configPackageConf :: Maybe FilePath
, configPackages :: [String]
, configBasePath :: Maybe FilePath
, configStrict :: [String]
, configTypecheckOnly :: Bool
, configRuntimePath :: Maybe FilePath
} deriving (Show)
newtype ModulePath = ModulePath { unModulePath :: [String] }
deriving (Eq, Ord, Show)
mkModulePath :: ModuleName a -> ModulePath
mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m
mkModulePaths :: ModuleName a -> [ModulePath]
mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m
mkModulePathFromQName :: QName a -> ModulePath
mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n
mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"
data CompileState = CompileState
{ stateInterfaces :: Map N.ModuleName Symbols
, stateRecordTypes :: [(N.QName,[N.QName])]
, stateRecords :: [(N.QName,[N.Name])]
, stateNewtypes :: [(N.QName, Maybe N.QName, N.Type)]
, stateImported :: [(N.ModuleName,FilePath)]
, stateNameDepth :: Integer
, stateModuleName :: N.ModuleName
, stateJsModulePaths :: Set ModulePath
, stateUseFromString :: Bool
, stateTypeSigs :: Map N.QName N.Type
} deriving (Show)
data CompileWriter = CompileWriter
{ writerCons :: [JsStmt]
, writerFayToJs :: [(String,JsExp)]
, writerJsToFay :: [(String,JsExp)]
}
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 :: S.Literal -> Compile JsExp
, readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]
}
newtype Compile a = Compile
{ unCompile :: (RWST CompileReader
CompileWriter
CompileState
(ErrorT CompileError (ModuleT (ModuleInfo Compile) IO)))
a
}
deriving (MonadState CompileState
,MonadError CompileError
,MonadReader CompileReader
,MonadWriter CompileWriter
,MonadIO
,Monad
,Functor
,Applicative
)
type CompileResult a
= Either CompileError
(a, CompileState, CompileWriter)
type CompileModule a
= ModuleT Symbols
IO
(CompileResult a)
instance MonadModule Compile where
type ModuleInfo Compile = Symbols
lookupInCache = liftModuleT . lookupInCache
insertInCache n m = liftModuleT $ insertInCache n m
getPackages = liftModuleT $ getPackages
readModuleInfo fps n = liftModuleT $ readModuleInfo fps n
liftModuleT :: ModuleT Symbols IO a -> Compile a
liftModuleT = Compile . lift . lift
data PrintState = PrintState
{ psPretty :: Bool
, psLine :: Int
, psColumn :: Int
, psMappings :: [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
= Couldn'tFindImport N.ModuleName [FilePath]
| EmptyDoBlock
| FfiFormatBadChars SrcSpanInfo String
| FfiFormatIncompleteArg SrcSpanInfo
| FfiFormatInvalidJavaScript SrcSpanInfo String String
| FfiFormatNoSuchArg SrcSpanInfo Int
| FfiNeedsTypeSig S.Decl
| GHCError String
| InvalidDoBlock
| ParseError S.SrcLoc String
| ShouldBeDesugared String
| UnableResolveQualified N.QName
| UnsupportedDeclaration S.Decl
| UnsupportedExportSpec N.ExportSpec
| UnsupportedExpression S.Exp
| UnsupportedFieldPattern S.PatField
| UnsupportedImport F.ImportDecl
| UnsupportedLet
| UnsupportedLetBinding S.Decl
| UnsupportedLiteral S.Literal
| UnsupportedModuleSyntax String F.Module
| UnsupportedPattern S.Pat
| UnsupportedQualStmt S.QualStmt
| UnsupportedRecursiveDo
| UnsupportedRhs S.Rhs
| UnsupportedWhereInAlt S.Alt
| UnsupportedWhereInMatch S.Match
deriving (Show)
instance Error CompileError
newtype Fay a = Fay (Identity a)
deriving Monad
data JsStmt
= JsVar JsName JsExp
| JsIf JsExp [JsStmt] [JsStmt]
| JsEarlyReturn JsExp
| JsThrow JsExp
| JsWhile JsExp [JsStmt]
| JsUpdate JsName JsExp
| JsSetProp JsName JsName JsExp
| JsSetQName (Maybe SrcSpan) N.QName JsExp
| JsSetModule ModulePath JsExp
| JsSetConstructor N.QName JsExp
| JsSetPropExtern JsName JsName JsExp
| JsContinue
| JsBlock [JsStmt]
| JsExpStmt JsExp
deriving (Show,Eq)
data JsExp
= JsName JsName
| JsRawExp String
| JsSeq [JsExp]
| JsFun (Maybe JsName) [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)]
| JsLitObj [(N.Name,JsExp)]
| JsUndefined
| JsAnd JsExp JsExp
| JsOr JsExp JsExp
deriving (Show,Eq)
data JsName
= JsNameVar N.QName
| JsThis
| JsParametrizedType
| JsThunk
| JsForce
| JsApply
| JsParam Integer
| JsTmp Integer
| JsConstructor N.QName
| JsBuiltIn N.Name
| JsModuleName N.ModuleName
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 N.Name [FundamentalType]
| Defined FundamentalType
| Nullable FundamentalType
| DateType
| StringType
| DoubleType
| IntType
| BoolType
| PtrType
| Automatic
| UnknownType
deriving (Show)
data SerializeContext = SerializeAnywhere | SerializeUserArg Int
deriving (Read,Show,Eq)