module Sindre.Compiler (
compileSindre,
ClassMap,
ObjectMap,
FuncMap,
GlobMap,
NewWidget(..),
NewObject(..),
Constructor,
ConstructorM,
Param(..),
paramM,
paramAs,
param,
noParam,
badValue,
Compiler,
value,
setValue,
)
where
import Sindre.Runtime
import Sindre.Sindre
import Sindre.Util
import System.Exit
import Control.Applicative
import Control.Arrow
import Control.Monad.Error
import Control.Monad.RWS.Lazy
import Control.Monad.State
import Data.Array
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Traversable(traverse)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Text as T
compileSindre :: MonadBackend m => Program
-> ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m
-> ([SindreOption], Arguments -> m ExitCode)
compileSindre prog cm om fm gm = (opts, start)
where (opts, prog', rootw) = compileProgram prog cm om fm gm
start argv =
let env = newEnv rootw argv
in execSindre env prog'
data Binding = Lexical IM.Key | Global GlobalBinding
data GlobalBinding = Constant Value | Mutable IM.Key
type ClassMap m = M.Map Identifier (Constructor m)
type ObjectMap m = M.Map Identifier (ObjectRef -> m (NewObject m))
type FuncMap m = M.Map Identifier (Compiler m ([Value] -> Sindre m Value))
type GlobMap m = M.Map Identifier (m Value)
data CompilerEnv m = CompilerEnv {
lexicalScope :: M.Map Identifier IM.Key
, functionRefs :: M.Map Identifier (Execution m Value)
, currentPos :: SourcePos
}
blankCompilerEnv :: CompilerEnv m
blankCompilerEnv = CompilerEnv {
lexicalScope = M.empty
, functionRefs = M.empty
, currentPos = nowhere
}
data CompilerState m = CompilerState {
globalScope :: M.Map Identifier GlobalBinding
, nextMutable :: IM.Key
}
blankCompilerState :: CompilerState m
blankCompilerState = CompilerState {
globalScope = M.empty
, nextMutable = 0
}
type Initialisation m = Sindre m ()
type Compiler m a = RWS (CompilerEnv m) (Initialisation m) (CompilerState m) a
runCompiler :: CompilerEnv m -> Compiler m a -> (a, Initialisation m)
runCompiler env m = evalRWS m env blankCompilerState
descend :: (a -> Compiler m b) -> P a -> Compiler m b
descend m (P p v) = local (\s -> s { currentPos = p }) $ m v
compileError :: String -> Compiler m a
compileError s = do pos <- position <$> asks currentPos
error $ pos ++ s
runtimeError :: Compiler m (String -> Execution m a)
runtimeError = do pos <- position <$> asks currentPos
return $ \s -> fail $ pos ++ s
function :: MonadBackend m => Identifier -> Compiler m (Execution m Value)
function k = maybe bad return =<< M.lookup k <$> asks functionRefs
where bad = compileError $ "Unknown function '"++k++"'"
defName :: MonadBackend m =>
Identifier -> GlobalBinding -> Compiler m ()
defName k b = do
known <- M.lookup k <$> gets globalScope
case known of
Just _ -> compileError $ "Multiple definitions of '"++k++"'"
Nothing -> modify $ \s -> s
{ globalScope = M.insert k b $ globalScope s }
defMutable :: MonadBackend m => Identifier -> Compiler m IM.Key
defMutable k = do
i <- gets nextMutable
modify $ \s -> s { nextMutable = i + 1 }
defName k $ Mutable i
return i
constant :: MonadBackend m => Identifier -> Compiler m Value
constant k = do
global <- gets globalScope
case M.lookup k global of
Just (Constant v) -> return v
_ -> compileError $ "Unknown constant '"++k++"'"
binding :: MonadBackend m => Identifier -> Compiler m Binding
binding k = do
lexical <- asks lexicalScope
global <- gets globalScope
case M.lookup k lexical of
Just b -> return $ Lexical b
Nothing -> case M.lookup k global of
Just b -> return $ Global b
Nothing -> Global <$> Mutable <$> defMutable k
value :: MonadBackend m => Identifier -> Compiler m (Execution m Value)
value k = do
bnd <- binding k
return $ case bnd of
Lexical k' -> lexicalVal k'
Global (Mutable k') -> sindre $ globalVal k'
Global (Constant v) -> return v
setValue :: MonadBackend m => Identifier -> Compiler m (Value -> Execution m ())
setValue k = do
bnd <- binding k
case bnd of
Lexical k' -> return $ setLexical k'
Global (Mutable k') -> return $ sindre . setGlobal k'
Global _ -> compileError $ "Cannot reassign constant '"++k++"'"
compileBackendGlobal :: MonadBackend m => (Identifier, m Value) -> Compiler m ()
compileBackendGlobal (k, v) = do
k' <- defMutable k
tell $ setGlobal k' =<< back v
compileGlobal :: MonadBackend m =>
(Identifier, P Expr) -> Compiler m ()
compileGlobal (k, e) = do
k' <- defMutable k
e' <- descend compileExpr e
tell $ setGlobal k' =<< execute e'
compileOption :: MonadBackend m =>
(Identifier, (SindreOption, Maybe Value))
-> Compiler m SindreOption
compileOption (k, (opt, def)) = do
let defval = fromMaybe falsity def
k' <- defMutable k
tell $ do
v <- M.lookup k <$> gets arguments
setGlobal k' $ maybe defval string v
return opt
compileObjs :: MonadBackend m =>
ObjectNum -> ObjectMap m ->
Compiler m (InstObjs m)
compileObjs r = zipWithM inst [r..] . M.toList
where inst r' (k, f) = do
let ref = (r', k, Just k)
defName k $ Constant $ Reference ref
return ((k, ref), f)
compileGUI :: MonadBackend m => ClassMap m -> (Maybe (P Expr), GUI)
-> Compiler m (ObjectNum, InstGUI m)
compileGUI m (pos, gui) = do
case pos of
Nothing -> return ()
Just re -> do re' <- descend compileExpr re
tell $ setRootPosition =<< execute re'
inst 0 gui
where inst r (GUI k c es cs) = do
es' <- traverse (descend compileExpr) es
(lastwr, children) <-
mapAccumLM (inst . (+1)) (r+length cs) childwrs
case k of
Just k' -> defName k' $ Constant $ Reference (lastwr, unP c, k)
Nothing -> return ()
c' <- descend (lookupClass m) c
orients' <- forM orients $ traverse $ descend compileExpr
return ( lastwr, InstGUI (r, unP c, k) c' es'
$ zip orients' children )
where (orients, childwrs) = unzip cs
compileProgram :: MonadBackend m => Program ->
ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m
-> ([SindreOption], Sindre m () , WidgetRef)
compileProgram prog cm om fm gm =
let env = blankCompilerEnv { functionRefs = funtable }
((funtable, evhandler, options, rootw), initialiser) =
runCompiler env $ do
mapM_ compileBackendGlobal $ M.toList gm
opts <- mapM (descend compileOption) $ programOptions prog
mapM_ (descend compileGlobal) $ programGlobals prog
(lastwr, gui) <- compileGUI cm $ programGUI prog
objs <- compileObjs (lastwr+1) om
let lastwr' = lastwr + length objs
handler <- compileActions $ programActions prog
tell $ do
ws <- map (second toWslot) <$> initGUI gui
os <- map (second toOslot) <$> initObjs objs
modify $ \s -> s { objects = array (0, lastwr') $ ws++os }
funs' <- forM funs $ descend $ \(k, f) ->
case (filter ((==k) . fst . unP) funs,
M.lookup k fm) of
(_:_:_, _) -> compileError $
"Multiple definitions of function '"++k++"'"
(_, Just _) -> compileError $
"Redefinition of built-in function '"++k++"'"
_ -> do f' <- compileFunction f
return (k, f')
fm' <- flip traverse fm $ \e -> do
e' <- e
return $ sindre . e' =<< IM.elems <$> sindre (gets execFrame)
begin <- mapM (descend compileStmt) $ programBegin prog
tell $ execute_ $ nextHere $ sequence_ begin
return (M.fromList funs' `M.union` fm',
handler, opts, rootwref gui)
in (options, initialiser >> eventLoop evhandler, rootw)
where funs = programFunctions prog
rootwref (InstGUI r _ _ _) = r
compileFunction :: MonadBackend m => Function -> Compiler m (Execution m Value)
compileFunction (Function args body) =
local (\s -> s { lexicalScope = argmap }) $ do
exs <- mapM (descend compileStmt) body
return $ do
sequence_ exs
return falsity
where argmap = M.fromList $ zip args [0..]
compileAction :: MonadBackend m => [Identifier] -> Action
-> Compiler m (Execution m ())
compileAction args (StmtAction body) =
local (\s -> s { lexicalScope = argmap }) $ do
exs <- mapM (descend compileStmt) body
return $ sequence_ exs
where argmap = M.fromList $ zip args [0..]
compilePattern :: MonadBackend m => Pattern
-> Compiler m ( Event -> Execution m (Maybe [Value])
, [Identifier])
compilePattern (ChordPattern kp1) = return (f, [])
where f (KeyPress kp2) | kp1 == kp2 = return $ Just []
| otherwise = return Nothing
f _ = return Nothing
compilePattern (OrPattern p1 p2) = do
(p1', ids1) <- compilePattern p1
(p2', ids2) <- compilePattern p2
let check ev = do
v1 <- p1' ev
v2 <- p2' ev
return $ case (v1, v2) of
(Just vs1, Just vs2) -> Just $ vs1++vs2
(Just vs1, Nothing) -> Just vs1
(Nothing, Just vs2) -> Just vs2
_ -> Nothing
return (check, ids1 ++ ids2)
compilePattern (SourcedPattern (NamedSource wn fn) evn args) = do
cv <- constant wn
case cv of
Reference wr -> return (f wr, args)
_ -> compileError $ "'" ++ wn ++ "' is not an object."
where f wr (NamedEvent evn2 vs (FieldSrc wr2 fn2))
| wr == wr2, evn2 == evn, fn2 `fcmp` fn = return $ Just vs
f wr (NamedEvent evn2 vs (ObjectSrc wr2))
| wr == wr2, evn2 == evn, fn == Nothing = return $ Just vs
f _ _ = return Nothing
compilePattern (SourcedPattern (GenericSource cn wn fn) evn args) =
return (f, wn:args)
where f (NamedEvent evn2 vs (FieldSrc wr2@(_,cn2,_) fn2))
| cn==cn2, evn2 == evn, fn2 `fcmp` fn =
return $ Just $ Reference wr2 : vs
f (NamedEvent evn2 vs (ObjectSrc wr2@(_,cn2,_)))
| cn==cn2, evn2 == evn, fn == Nothing =
return $ Just $ Reference wr2 : vs
f _ = return Nothing
fcmp :: Identifier -> Maybe Identifier -> Bool
fcmp f = fromMaybe True . liftM (==f)
compileActions :: MonadBackend m => [P (Pattern, Action)]
-> Compiler m (EventHandler m)
compileActions reacts = do
reacts' <- mapM (descend compileReaction) reacts
return $ \ev -> do dispatch ev reacts'
case ev of
KeyPress _ ->
flip recvEvent ev =<< sindre (gets kbdFocus)
_ -> return ()
where compileReaction (pat, act) = do
(pat', args) <- compilePattern pat
act' <- compileAction args act
return (pat', act')
dispatch ev = mapM_ $ \(applies, apply) -> do
vs <- applies ev
case vs of
Just vs' -> setScope vs' apply
Nothing -> return ()
compileStmt :: MonadBackend m => Stmt -> Compiler m (Execution m ())
compileStmt (Print xs) = do
xs' <- mapM (descend compileExpr) xs
return $ do
vs <- map show <$> sequence xs'
back $ do
printVal $ unwords vs
printVal "\n"
compileStmt (Exit Nothing) =
return $ sindre $ quitSindre ExitSuccess
compileStmt (Exit (Just e)) = do
e' <- descend compileExpr e
bad <- runtimeError
return $ do
v <- e'
case mold v :: Maybe Integer of
Just 0 -> sindre $ quitSindre ExitSuccess
Just x -> sindre $ quitSindre $ ExitFailure $ fi x
Nothing -> bad "Exit code must be an integer"
compileStmt (Expr e) = do
e' <- descend compileExpr e
return $ e' >> return ()
compileStmt (Return (Just e)) = do
e' <- descend compileExpr e
return $ doReturn =<< e'
compileStmt (Return Nothing) =
return $ doReturn falsity
compileStmt Next = return doNext
compileStmt Break = return doBreak
compileStmt Continue = return doCont
compileStmt (If e trueb falseb) = do
e' <- descend compileExpr e
trueb' <- mapM (descend compileStmt) trueb
falseb' <- mapM (descend compileStmt) falseb
return $ do
v <- e'
sequence_ $ if true v then trueb' else falseb'
compileStmt (While c body) =
compileStmt $ For blank c blank body
where blank = Literal falsity `at` c
compileStmt (For e1 e2 e3 body) = do
body' <- mapM (descend compileStmt) body
e1' <- descend compileExpr e1
e2' <- descend compileExpr e2
e3' <- descend compileExpr e3
let stmt = do
v <- e2'
when (true v) $ contHere (sequence_ body') >> e3' >> stmt
return $ e1' >> breakHere stmt
compileStmt (Do body c) = do
body' <- mapM (descend compileStmt) body
loop' <- descend compileStmt $ While c body `at` c
return $ breakHere $ contHere (sequence_ body') >> loop'
compileStmt (Focus e) = do
e' <- descend compileExpr e
bad <- runtimeError
return $ do
v <- e'
case v of
Reference r -> sindre $ modify $ \s -> s { kbdFocus = r }
_ -> bad "Focus is not a widget reference"
compileExpr :: MonadBackend m => Expr -> Compiler m (Execution m Value)
compileExpr (Literal v) = return $ return v
compileExpr (Var v) = value v
compileExpr (P _ (Var k) `Assign` e) = do
e' <- descend compileExpr e
set <- setValue k
return $ do
v <- e'
set v
return v
compileExpr (Not e) = do
e' <- descend compileExpr e
return $ do
v <- e'
return $ if true v then falsity else truth
compileExpr (e1 `Equal` e2) =
compileBinop e1 e2 $ \v1 v2 _ ->
return $! if v1 == v2 then truth else falsity
compileExpr (e1 `LessThan` e2) =
compileBinop e1 e2 $ \v1 v2 _ ->
return $! if v1 < v2 then truth else falsity
compileExpr (e1 `LessEql` e2) =
compileBinop e1 e2 $ \v1 v2 _ ->
return $! if v1 <= v2 then truth else falsity
compileExpr (P _ (P _ (Var k) `Lookup` e1) `Assign` e2) = do
e1' <- descend compileExpr e1
e2' <- descend compileExpr e2
k' <- value k
set <- setValue k
bad <- runtimeError
return $ do
v1 <- e1'
v2 <- e2'
o <- k'
case o of
Dict m ->
set $! Dict $! M.insert v1 v2 m
_ -> bad "Not a dictionary"
return v2
compileExpr (P _ (s `FieldOf` oe) `Assign` e) = do
oe' <- descend compileExpr oe
e' <- descend compileExpr e
bad <- runtimeError
return $ do
o <- oe'
v <- e'
case o of
Reference wr -> sindre $ do _ <- fieldSet wr s v
return v
_ -> bad "Not an object"
compileExpr (_ `Assign` _) = compileError "Cannot assign to rvalue"
compileExpr (e `Lookup` fe) = do
fe' <- descend compileExpr fe
e' <- descend compileExpr e
bad <- runtimeError
return $ do
v <- fe'
o <- e'
case o of
Dict m -> return $ fromMaybe falsity $! M.lookup v m
_ -> bad "Not a dictionary"
compileExpr (s `FieldOf` oe) = do
oe' <- descend compileExpr oe
bad <- runtimeError
return $ do
o <- oe'
case o of
Reference wr -> sindre $ fieldGet wr s
_ -> bad "Not an object"
compileExpr (Methcall oe meth argexps) = do
argexps' <- mapM (descend compileExpr) argexps
o' <- descend compileExpr oe
bad <- runtimeError
return $ do
argvs <- sequence argexps'
v <- o'
case v of
Reference wr -> callMethod wr meth argvs
_ -> bad "Not an object"
compileExpr (Funcall f argexps) = do
argexps' <- mapM (descend compileExpr) argexps
f' <- function f
return $ do
argv <- sequence argexps'
enterScope argv $ returnHere f'
compileExpr (Cond c trueb falseb) = do
c' <- descend compileExpr c
trueb' <- descend compileExpr trueb
falseb' <- descend compileExpr falseb
return $ do
v <- c'
if true v then trueb' else falseb'
compileExpr (Concat e1 e2) = compileBinop e1 e2 $ \v1 v2 bad ->
case (mold v1, mold v2) of
(Just v1', Just v2') -> return $ StringV $! v1' `T.append` v2'
_ -> bad "Can only concatenate strings"
compileExpr (PostInc e) = do
e' <- descend compileExpr e
p' <- compileExpr $ e `Assign` (Plus e (Literal (Number 1) `at` e) `at` e)
return $ e' <* p'
compileExpr (PostDec e) = do
e' <- descend compileExpr e
p' <- compileExpr $ e `Assign` (Minus e (Literal (Number 1) `at` e) `at` e)
return $ e' <* p'
compileExpr (e1 `Plus` e2) = compileArithop (+) "add" e1 e2
compileExpr (e1 `Minus` e2) = compileArithop () "subtract" e1 e2
compileExpr (e1 `Times` e2) = compileArithop (*) "multiply" e1 e2
compileExpr (e1 `Divided` e2) = compileArithop (/) "divide" e1 e2
compileExpr (e1 `Modulo` e2) = compileArithop mod' "take modulo" e1 e2
compileExpr (e1 `RaisedTo` e2) = compileArithop (**) "exponentiate" e1 e2
compileBinop :: MonadBackend m =>
P Expr -> P Expr ->
(Value -> Value -> (String -> Execution m a)
-> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop e1 e2 op = do
e1' <- descend compileExpr e1
e2' <- descend compileExpr e2
bad <- runtimeError
return $ do
v1 <- e1'
v2 <- e2'
op v1 v2 bad
compileArithop :: MonadBackend m =>
(Double -> Double -> Double)
-> String -> P Expr -> P Expr
-> Compiler m (Execution m Value)
compileArithop op opstr e1 e2 = compileBinop e1 e2 $ \v1 v2 bad ->
case (mold v1, mold v2) of
(Just v1', Just v2') -> return $ Number $! v1' `op` v2'
_ -> bad $ "Can only " ++ opstr ++ " numbers"
data NewWidget m = forall s . Widget m s => NewWidget s
data NewObject m = forall s . Object m s => NewObject s
type WidgetArgs m = M.Map Identifier (Execution m Value)
type Constructor m =
WidgetRef -> [(Maybe Value, ObjectRef)] ->
ConstructorM m (NewWidget m)
data InstGUI m = InstGUI WidgetRef
(Constructor m)
(WidgetArgs m)
[(Maybe (Execution m Value), InstGUI m)]
type InstObjs m = [((Identifier, ObjectRef),
ObjectRef -> m (NewObject m))]
initGUI :: MonadBackend m => InstGUI m
-> Sindre m [(ObjectNum, (NewWidget m, Constraints))]
initGUI (InstGUI r@(wn,_,_) f args cs) = do
args' <- traverse execute args
childrefs <- forM cs $ \(e, InstGUI r' _ _ _) -> do
v <- case e of Just e' -> Just <$> execute e'
Nothing -> return Nothing
return (v,r')
let constructor = do
minw <- Just <$> param "minwidth" <|> return Nothing
minh <- Just <$> param "minheight" <|> return Nothing
maxw <- Just <$> param "maxwidth" <|> return Nothing
maxh <- Just <$> param "maxheight" <|> return Nothing
s <- f r childrefs
return (s, ((minw, maxw), (minh, maxh)))
s <- runConstructor constructor args'
children <- liftM concat $ mapM (initGUI . snd) cs
return $ (wn, s):children
lookupClass :: ClassMap m -> Identifier -> Compiler m (Constructor m)
lookupClass m k = maybe unknown return $ M.lookup k m
where unknown = compileError $ "Unknown class '" ++ k ++ "'"
initObjs :: MonadBackend m =>
InstObjs m -> Sindre m [(ObjectNum, NewObject m)]
initObjs = mapM $ \((_, r@(r',_,_)), con) -> do
o <- back $ con r
return (r', o)
toWslot :: (NewWidget m, Constraints) -> DataSlot m
toWslot (NewWidget s, cs) = WidgetSlot s $ WidgetState cs $ Rectangle 0 0 0 0
toOslot :: NewObject m -> DataSlot m
toOslot (NewObject s) = ObjectSlot s
class MonadBackend m => Param m a where
moldM :: Value -> m (Maybe a)
data ParamError = NoParam Identifier | BadValue Identifier Value
deriving (Show)
instance Error ParamError where
strMsg = flip BadValue falsity
newtype ConstructorM m a = ConstructorM (ErrorT ParamError
(StateT (M.Map Identifier Value)
(Sindre m))
a)
deriving ( MonadState (M.Map Identifier Value)
, MonadError ParamError
, Monad, Functor, Applicative)
noParam :: String -> ConstructorM m a
noParam = throwError . NoParam
badValue :: String -> Value -> ConstructorM m a
badValue k = throwError . BadValue k
runConstructor :: MonadBackend m => ConstructorM m a
-> M.Map Identifier Value -> Sindre m a
runConstructor (ConstructorM c) m = do
(v, m') <- runStateT (runErrorT c) m
case v of
Left (NoParam k) -> fail $ "Missing argument '"++k++"'"
Left (BadValue k v') -> fail $ "Bad value "++show v'++" for argument '"
++k++"'"++maybe "" ((": "++) . show) (M.lookup k m)
Right _ | m' /= M.empty ->
fail $ "Surplus arguments: " ++ intercalate "," (M.keys m')
Right v' -> return v'
instance MonadBackend m => Alternative (ConstructorM m) where
empty = noParam "<none>"
x <|> y = x `catchError` f
where f (NoParam k) = y `catchError` g k
f (BadValue k v) | not $ true v = y `catchError` g k
f e = throwError e
g k1 (NoParam _) = noParam k1
g _ e = throwError e
instance MonadBackend im => MonadSindre im ConstructorM where
sindre = ConstructorM . lift . lift
instance (MonadIO m, MonadBackend m) => MonadIO (ConstructorM m) where
liftIO = back . io
paramAs :: MonadBackend m =>
Identifier -> (Value -> Maybe a) -> ConstructorM m a
paramAs k f = paramAsM k (return . f)
paramAsM :: MonadBackend m => Identifier
-> (Value -> m (Maybe a)) -> ConstructorM m a
paramAsM k mf = do m <- get
case M.lookup k m of
Nothing -> noParam k
Just v -> do put (k `M.delete` m)
back (mf v) >>=
maybe (badValue k v) return
paramM :: (Param m a, MonadBackend m) => Identifier -> ConstructorM m a
paramM k = paramAsM k moldM
param :: (Mold a, MonadBackend m) => Identifier -> ConstructorM m a
param k = paramAs k mold