{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Sindre.Compiler
-- License     :  MIT-style (see LICENSE)
--
-- Stability   :  provisional
-- Portability :  portable
--
-- Transforming a Sindre program into a callable function.
--
-----------------------------------------------------------------------------
module Sindre.Compiler (
  -- * Main Entry Point
  compileSindre,
  ClassMap,
  ObjectMap,
  FuncMap,
  GlobMap,
  -- * Object Construction
  Constructor,
  ConstructorM,
  Param(..),
  paramM,
  paramAs,
  param,
  noParam,
  badValue,
  -- * Compiler Interface

  -- | These definitions can be used in builtin functions that may
  -- need to change global variables.
  Compiler,
  value,
  setValue,
                       )
    where

import Sindre.Runtime
import Sindre.Sindre
import Sindre.Util

import System.Exit

import Control.Applicative
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 (for, traverse)
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Text as T

-- | Given a Sindre program and its environment, compile the program
-- and return a pair of command-line options accepted by the program,
-- and a startup function.  The program can be executed by calling the
-- startup function with the command-like arguments and an initial
-- value for the root widget.  If compilation fails, an IO exception
-- is raised.
compileSindre :: MonadBackend m => Program
              -> ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m
              -> ([SindreOption], Arguments -> m ExitCode)
compileSindre :: Program
-> ClassMap m
-> ObjectMap m
-> FuncMap m
-> GlobMap m
-> ([SindreOption], Arguments -> m ExitCode)
compileSindre Program
prog ClassMap m
cm ObjectMap m
om FuncMap m
fm GlobMap m
gm = ([SindreOption]
opts, Arguments -> m ExitCode
start)
  where ([SindreOption]
opts, Sindre m ()
prog', WidgetRef
rootw) = Program
-> ClassMap m
-> ObjectMap m
-> FuncMap m
-> GlobMap m
-> ([SindreOption], Sindre m (), WidgetRef)
forall (m :: * -> *).
MonadBackend m =>
Program
-> ClassMap m
-> ObjectMap m
-> FuncMap m
-> GlobMap m
-> ([SindreOption], Sindre m (), WidgetRef)
compileProgram Program
prog ClassMap m
cm ObjectMap m
om FuncMap m
fm GlobMap m
gm
        start :: Arguments -> m ExitCode
start Arguments
argv =
          let env :: SindreEnv m
env = WidgetRef -> Arguments -> SindreEnv m
forall (m :: * -> *). WidgetRef -> Arguments -> SindreEnv m
newEnv WidgetRef
rootw Arguments
argv
          in SindreEnv m -> Sindre m () -> m ExitCode
forall (m :: * -> *) a.
MonadBackend m =>
SindreEnv m -> Sindre m a -> m ExitCode
execSindre SindreEnv m
forall (m :: * -> *). SindreEnv m
env Sindre m ()
prog'

data Binding = Lexical IM.Key | Global GlobalBinding
data GlobalBinding = Constant Value | Mutable IM.Key

-- | Mapping from class names to constructors.
type ClassMap m  = M.Map Identifier (Constructor m)
-- | Mapping from object names to object constructor functions.
type ObjectMap m = M.Map Identifier (ObjectRef -> m (NewObject m))
-- | Mapping from function names to built-in functions.  These must
-- first be executed in the 'Compiler' monad as they may have specific
-- requirements of the environment.
type FuncMap m   = M.Map Identifier (Compiler m ([Value] -> Sindre m Value))
-- | Mapping from names of global variables to computations that yield
-- their initial values.
type GlobMap m   = M.Map Identifier (m Value)

data CompilerEnv m = CompilerEnv {
      CompilerEnv m -> Map Identifier Key
lexicalScope :: M.Map Identifier IM.Key
    , CompilerEnv m -> Map Identifier (Execution m Value)
functionRefs :: M.Map Identifier (Execution m Value)
    , CompilerEnv m -> SourcePos
currentPos   :: SourcePos
    }

blankCompilerEnv :: CompilerEnv m
blankCompilerEnv :: CompilerEnv m
blankCompilerEnv = CompilerEnv :: forall (m :: * -> *).
Map Identifier Key
-> Map Identifier (Execution m Value) -> SourcePos -> CompilerEnv m
CompilerEnv {
                     lexicalScope :: Map Identifier Key
lexicalScope = Map Identifier Key
forall k a. Map k a
M.empty
                   , functionRefs :: Map Identifier (Execution m Value)
functionRefs = Map Identifier (Execution m Value)
forall k a. Map k a
M.empty
                   , currentPos :: SourcePos
currentPos = SourcePos
nowhere
                   }

data CompilerState = CompilerState {
      CompilerState -> Map Identifier GlobalBinding
globalScope :: M.Map Identifier GlobalBinding
    , CompilerState -> Key
nextMutable :: IM.Key
    }

blankCompilerState :: CompilerState
blankCompilerState :: CompilerState
blankCompilerState = CompilerState :: Map Identifier GlobalBinding -> Key -> CompilerState
CompilerState {
                       globalScope :: Map Identifier GlobalBinding
globalScope = Map Identifier GlobalBinding
forall k a. Map k a
M.empty
                     , nextMutable :: Key
nextMutable = Key
0
                     }

type Initialisation m = Sindre m ()

-- | Monad inside which compilation takes place.
type Compiler m a = RWS (CompilerEnv m) (Initialisation m) CompilerState a

runCompiler :: CompilerEnv m -> Compiler m a -> (a, Initialisation m)
runCompiler :: CompilerEnv m -> Compiler m a -> (a, Initialisation m)
runCompiler CompilerEnv m
env Compiler m a
m = Compiler m a
-> CompilerEnv m -> CompilerState -> (a, Initialisation m)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS Compiler m a
m CompilerEnv m
env CompilerState
blankCompilerState

descend :: (a -> Compiler m b) -> P a -> Compiler m b
descend :: (a -> Compiler m b) -> P a -> Compiler m b
descend a -> Compiler m b
m (P SourcePos
p a
v) = (CompilerEnv m -> CompilerEnv m) -> Compiler m b -> Compiler m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CompilerEnv m
s -> CompilerEnv m
s { currentPos :: SourcePos
currentPos = SourcePos
p }) (Compiler m b -> Compiler m b) -> Compiler m b -> Compiler m b
forall a b. (a -> b) -> a -> b
$ a -> Compiler m b
m a
v

compileError :: String -> Compiler m a
compileError :: Identifier -> Compiler m a
compileError Identifier
s = do Identifier
pos <- SourcePos -> Identifier
position (SourcePos -> Identifier)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity SourcePos
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     Identifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompilerEnv m -> SourcePos)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity SourcePos
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv m -> SourcePos
forall (m :: * -> *). CompilerEnv m -> SourcePos
currentPos
                    Identifier -> Compiler m a
forall a. HasCallStack => Identifier -> a
error (Identifier -> Compiler m a) -> Identifier -> Compiler m a
forall a b. (a -> b) -> a -> b
$ Identifier
pos Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
s

runtimeError :: MonadFail m => Compiler m (String -> Execution m a)
runtimeError :: Compiler m (Identifier -> Execution m a)
runtimeError = do Identifier
pos <- SourcePos -> Identifier
position (SourcePos -> Identifier)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity SourcePos
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     Identifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompilerEnv m -> SourcePos)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity SourcePos
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv m -> SourcePos
forall (m :: * -> *). CompilerEnv m -> SourcePos
currentPos
                  (Identifier -> Execution m a)
-> Compiler m (Identifier -> Execution m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Identifier -> Execution m a)
 -> Compiler m (Identifier -> Execution m a))
-> (Identifier -> Execution m a)
-> Compiler m (Identifier -> Execution m a)
forall a b. (a -> b) -> a -> b
$ \Identifier
s -> Identifier -> Execution m a
forall (m :: * -> *) a. MonadFail m => Identifier -> m a
fail (Identifier -> Execution m a) -> Identifier -> Execution m a
forall a b. (a -> b) -> a -> b
$ Identifier
pos Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
s

function :: MonadBackend m => Identifier -> Compiler m (Execution m Value)
function :: Identifier -> Compiler m (Execution m Value)
function Identifier
k = Compiler m (Execution m Value)
-> (Execution m Value -> Compiler m (Execution m Value))
-> Maybe (Execution m Value)
-> Compiler m (Execution m Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Compiler m (Execution m Value)
forall (m :: * -> *) a. Compiler m a
bad Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Execution m Value) -> Compiler m (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Maybe (Execution m Value))
-> Compiler m (Execution m Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Identifier
-> Map Identifier (Execution m Value) -> Maybe (Execution m Value)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k (Map Identifier (Execution m Value) -> Maybe (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Maybe (Execution m Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompilerEnv m -> Map Identifier (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier (Execution m Value))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv m -> Map Identifier (Execution m Value)
forall (m :: * -> *).
CompilerEnv m -> Map Identifier (Execution m Value)
functionRefs
    where bad :: Compiler m a
bad = Identifier -> Compiler m a
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier -> Compiler m a) -> Identifier -> Compiler m a
forall a b. (a -> b) -> a -> b
$ Identifier
"Unknown function '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"

defName :: MonadBackend m =>
           Identifier -> GlobalBinding -> Compiler m ()
defName :: Identifier -> GlobalBinding -> Compiler m ()
defName Identifier
k GlobalBinding
b = do
  Maybe GlobalBinding
known <- Identifier -> Map Identifier GlobalBinding -> Maybe GlobalBinding
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k (Map Identifier GlobalBinding -> Maybe GlobalBinding)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier GlobalBinding)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Maybe GlobalBinding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompilerState -> Map Identifier GlobalBinding)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier GlobalBinding)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState -> Map Identifier GlobalBinding
globalScope
  case Maybe GlobalBinding
known of
    Just GlobalBinding
_ -> Identifier -> Compiler m ()
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier -> Compiler m ()) -> Identifier -> Compiler m ()
forall a b. (a -> b) -> a -> b
$ Identifier
"Multiple definitions of '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"
    Maybe GlobalBinding
Nothing -> (CompilerState -> CompilerState) -> Compiler m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState -> CompilerState) -> Compiler m ())
-> (CompilerState -> CompilerState) -> Compiler m ()
forall a b. (a -> b) -> a -> b
$ \CompilerState
s -> CompilerState
s
                { globalScope :: Map Identifier GlobalBinding
globalScope = Identifier
-> GlobalBinding
-> Map Identifier GlobalBinding
-> Map Identifier GlobalBinding
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Identifier
k GlobalBinding
b (Map Identifier GlobalBinding -> Map Identifier GlobalBinding)
-> Map Identifier GlobalBinding -> Map Identifier GlobalBinding
forall a b. (a -> b) -> a -> b
$ CompilerState -> Map Identifier GlobalBinding
globalScope CompilerState
s }

defMutable :: MonadBackend m => Identifier -> Compiler m IM.Key
defMutable :: Identifier -> Compiler m Key
defMutable Identifier
k = do
  Key
i <- (CompilerState -> Key) -> Compiler m Key
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState -> Key
nextMutable
  (CompilerState -> CompilerState)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState -> CompilerState)
 -> RWST
      (CompilerEnv m) (Initialisation m) CompilerState Identity ())
-> (CompilerState -> CompilerState)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ \CompilerState
s -> CompilerState
s { nextMutable :: Key
nextMutable = Key
i Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1 }
  Identifier
-> GlobalBinding
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall (m :: * -> *).
MonadBackend m =>
Identifier -> GlobalBinding -> Compiler m ()
defName Identifier
k (GlobalBinding
 -> RWST
      (CompilerEnv m) (Initialisation m) CompilerState Identity ())
-> GlobalBinding
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ Key -> GlobalBinding
Mutable Key
i
  Key -> Compiler m Key
forall (m :: * -> *) a. Monad m => a -> m a
return Key
i

constant :: MonadBackend m => Identifier -> Compiler m Value
constant :: Identifier -> Compiler m Value
constant Identifier
k = do
  Map Identifier GlobalBinding
global <- (CompilerState -> Map Identifier GlobalBinding)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier GlobalBinding)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState -> Map Identifier GlobalBinding
globalScope
  case Identifier -> Map Identifier GlobalBinding -> Maybe GlobalBinding
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k Map Identifier GlobalBinding
global of
    Just (Constant Value
v) -> Value -> Compiler m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
    Maybe GlobalBinding
_ -> Identifier -> Compiler m Value
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier -> Compiler m Value) -> Identifier -> Compiler m Value
forall a b. (a -> b) -> a -> b
$ Identifier
"Unknown constant '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"

binding :: MonadBackend m => Identifier -> Compiler m Binding
binding :: Identifier -> Compiler m Binding
binding Identifier
k = do
  Map Identifier Key
lexical  <- (CompilerEnv m -> Map Identifier Key)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier Key)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv m -> Map Identifier Key
forall (m :: * -> *). CompilerEnv m -> Map Identifier Key
lexicalScope
  Map Identifier GlobalBinding
global   <- (CompilerState -> Map Identifier GlobalBinding)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier GlobalBinding)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState -> Map Identifier GlobalBinding
globalScope
  case Identifier -> Map Identifier Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k Map Identifier Key
lexical of
    Just Key
b -> Binding -> Compiler m Binding
forall (m :: * -> *) a. Monad m => a -> m a
return (Binding -> Compiler m Binding) -> Binding -> Compiler m Binding
forall a b. (a -> b) -> a -> b
$ Key -> Binding
Lexical Key
b
    Maybe Key
Nothing -> case Identifier -> Map Identifier GlobalBinding -> Maybe GlobalBinding
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k Map Identifier GlobalBinding
global of
                 Just GlobalBinding
b -> Binding -> Compiler m Binding
forall (m :: * -> *) a. Monad m => a -> m a
return (Binding -> Compiler m Binding) -> Binding -> Compiler m Binding
forall a b. (a -> b) -> a -> b
$ GlobalBinding -> Binding
Global GlobalBinding
b
                 Maybe GlobalBinding
Nothing -> GlobalBinding -> Binding
Global (GlobalBinding -> Binding)
-> (Key -> GlobalBinding) -> Key -> Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> GlobalBinding
Mutable (Key -> Binding)
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity Key
-> Compiler m Binding
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity Key
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Key
defMutable Identifier
k

-- | Given a variable name, return a computation that will yield the
-- value of the variable when executed.
value :: MonadBackend m => Identifier -> Compiler m (Execution m Value)
value :: Identifier -> Compiler m (Execution m Value)
value Identifier
k = do
  Binding
bnd <- Identifier -> Compiler m Binding
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Binding
binding Identifier
k
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ case Binding
bnd of
    Lexical Key
k' -> Key -> Execution m Value
forall (m :: * -> *). MonadBackend m => Key -> Execution m Value
lexicalVal Key
k'
    Global (Mutable Key
k') -> Sindre m Value -> Execution m Value
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Sindre m Value -> Execution m Value)
-> Sindre m Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Key -> Sindre m Value
forall (m :: * -> *). MonadBackend m => Key -> Sindre m Value
globalVal Key
k'
    Global (Constant Value
v) -> Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

-- | Given a variable name, return a computation that can be used to
-- set the value of the variable when executed.
setValue :: MonadBackend m => Identifier -> Compiler m (Value -> Execution m ())
setValue :: Identifier -> Compiler m (Value -> Execution m ())
setValue Identifier
k = do
  Binding
bnd <- Identifier -> Compiler m Binding
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Binding
binding Identifier
k
  case Binding
bnd of
    Lexical Key
k' -> (Value -> Execution m ()) -> Compiler m (Value -> Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value -> Execution m ()) -> Compiler m (Value -> Execution m ()))
-> (Value -> Execution m ())
-> Compiler m (Value -> Execution m ())
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Key -> Value -> Execution m ()
setLexical Key
k'
    Global (Mutable Key
k') -> (Value -> Execution m ()) -> Compiler m (Value -> Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Value -> Execution m ()) -> Compiler m (Value -> Execution m ()))
-> (Value -> Execution m ())
-> Compiler m (Value -> Execution m ())
forall a b. (a -> b) -> a -> b
$ Sindre m () -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Sindre m () -> Execution m ())
-> (Value -> Sindre m ()) -> Value -> Execution m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Sindre m ()
forall (m :: * -> *). MonadBackend m => Key -> Value -> Sindre m ()
setGlobal Key
k'
    Global GlobalBinding
_ -> Identifier -> Compiler m (Value -> Execution m ())
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier -> Compiler m (Value -> Execution m ()))
-> Identifier -> Compiler m (Value -> Execution m ())
forall a b. (a -> b) -> a -> b
$ Identifier
"Cannot reassign constant '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"

compileBackendGlobal :: MonadBackend m => (Identifier, m Value) -> Compiler m ()
compileBackendGlobal :: (Identifier, m Value) -> Compiler m ()
compileBackendGlobal (Identifier
k, m Value
v) = do
  Key
k' <- Identifier -> Compiler m Key
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Key
defMutable Identifier
k
  Sindre m () -> Compiler m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Sindre m () -> Compiler m ()) -> Sindre m () -> Compiler m ()
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Sindre m ()
forall (m :: * -> *). MonadBackend m => Key -> Value -> Sindre m ()
setGlobal Key
k' (Value -> Sindre m ()) -> Sindre m Value -> Sindre m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Value -> Sindre m Value
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back m Value
v

compileGlobal :: MonadBackend m =>
                 (Identifier, P Expr) -> Compiler m ()
compileGlobal :: (Identifier, P Expr) -> Compiler m ()
compileGlobal (Identifier
k, P Expr
e) = do
  Key
k' <- Identifier -> Compiler m Key
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Key
defMutable Identifier
k
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Sindre m () -> Compiler m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Sindre m () -> Compiler m ()) -> Sindre m () -> Compiler m ()
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Sindre m ()
forall (m :: * -> *). MonadBackend m => Key -> Value -> Sindre m ()
setGlobal Key
k' (Value -> Sindre m ()) -> Sindre m Value -> Sindre m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Execution m Value -> Sindre m Value
forall (m :: * -> *).
MonadBackend m =>
Execution m Value -> Sindre m Value
execute Execution m Value
e'

compileOption :: MonadBackend m =>
                 (Identifier, (SindreOption, Maybe Value))
              -> Compiler m SindreOption
compileOption :: (Identifier, (SindreOption, Maybe Value))
-> Compiler m SindreOption
compileOption (Identifier
k, (SindreOption
opt, Maybe Value
def)) = do
  let defval :: Value
defval = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
falsity Maybe Value
def
  Key
k' <- Identifier -> Compiler m Key
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Key
defMutable Identifier
k
  Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Sindre m ()
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe Identifier
v <- Identifier -> Arguments -> Maybe Identifier
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k (Arguments -> Maybe Identifier)
-> Sindre m Arguments -> Sindre m (Maybe Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SindreEnv m -> Arguments) -> Sindre m Arguments
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SindreEnv m -> Arguments
forall (m :: * -> *). SindreEnv m -> Arguments
arguments
    Key -> Value -> Sindre m ()
forall (m :: * -> *). MonadBackend m => Key -> Value -> Sindre m ()
setGlobal Key
k' (Value -> Sindre m ()) -> Value -> Sindre m ()
forall a b. (a -> b) -> a -> b
$ Value -> (Identifier -> Value) -> Maybe Identifier -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
defval Identifier -> Value
string Maybe Identifier
v
  SindreOption -> Compiler m SindreOption
forall (m :: * -> *) a. Monad m => a -> m a
return SindreOption
opt

compileObjs :: MonadBackend m =>
               ObjectNum -> ObjectMap m ->
               Compiler m (InstObjs m)
compileObjs :: Key -> ObjectMap m -> Compiler m (InstObjs m)
compileObjs Key
r = (Key
 -> (Identifier, WidgetRef -> m (NewObject m))
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      ((Identifier, WidgetRef), WidgetRef -> m (NewObject m)))
-> [Key]
-> [(Identifier, WidgetRef -> m (NewObject m))]
-> Compiler m (InstObjs m)
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Key
-> (Identifier, WidgetRef -> m (NewObject m))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     ((Identifier, WidgetRef), WidgetRef -> m (NewObject m))
forall (m :: * -> *) b.
MonadBackend m =>
Key
-> (Identifier, b)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     ((Identifier, WidgetRef), b)
inst [Key
r..] ([(Identifier, WidgetRef -> m (NewObject m))]
 -> Compiler m (InstObjs m))
-> (ObjectMap m -> [(Identifier, WidgetRef -> m (NewObject m))])
-> ObjectMap m
-> Compiler m (InstObjs m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectMap m -> [(Identifier, WidgetRef -> m (NewObject m))]
forall k a. Map k a -> [(k, a)]
M.toList
    where inst :: Key
-> (Identifier, b)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     ((Identifier, WidgetRef), b)
inst Key
r' (Identifier
k, b
f) = do
            let ref :: WidgetRef
ref = (Key
r', Identifier
k, Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just Identifier
k)
            Identifier -> GlobalBinding -> Compiler m ()
forall (m :: * -> *).
MonadBackend m =>
Identifier -> GlobalBinding -> Compiler m ()
defName Identifier
k (GlobalBinding -> Compiler m ()) -> GlobalBinding -> Compiler m ()
forall a b. (a -> b) -> a -> b
$ Value -> GlobalBinding
Constant (Value -> GlobalBinding) -> Value -> GlobalBinding
forall a b. (a -> b) -> a -> b
$ WidgetRef -> Value
Reference WidgetRef
ref
            ((Identifier, WidgetRef), b)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     ((Identifier, WidgetRef), b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Identifier
k, WidgetRef
ref), b
f)

compileGUI :: MonadBackend m => ClassMap m -> (Maybe (P Expr), GUI)
           -> Compiler m (ObjectNum, InstGUI m)
compileGUI :: ClassMap m -> (Maybe (P Expr), GUI) -> Compiler m (Key, InstGUI m)
compileGUI ClassMap m
m (Maybe (P Expr)
pos, GUI
gui) = do
  case Maybe (P Expr)
pos of
    Maybe (P Expr)
Nothing -> ()
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just P Expr
re -> do Execution m Value
re' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
re
                  Initialisation m
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Initialisation m
 -> RWST
      (CompilerEnv m) (Initialisation m) CompilerState Identity ())
-> Initialisation m
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ Value -> Initialisation m
forall (m :: * -> *). MonadBackend m => Value -> Sindre m ()
setRootPosition (Value -> Initialisation m) -> Sindre m Value -> Initialisation m
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Execution m Value -> Sindre m Value
forall (m :: * -> *).
MonadBackend m =>
Execution m Value -> Sindre m Value
execute Execution m Value
re'
  Key -> GUI -> Compiler m (Key, InstGUI m)
inst Key
0 GUI
gui
    where inst :: Key -> GUI -> Compiler m (Key, InstGUI m)
inst Key
r (GUI Maybe Identifier
k P Identifier
c WidgetArgs
es [(Maybe (P Expr), GUI)]
cs) = do
            Map Identifier (Execution m Value)
es' <- (P Expr -> Compiler m (Execution m Value))
-> WidgetArgs
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Map Identifier (Execution m Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr) WidgetArgs
es
            (Key
lastwr, [InstGUI m]
children) <-
                (Key -> GUI -> Compiler m (Key, InstGUI m))
-> Key
-> [GUI]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Key, [InstGUI m])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (Key -> GUI -> Compiler m (Key, InstGUI m)
inst (Key -> GUI -> Compiler m (Key, InstGUI m))
-> (Key -> Key) -> Key -> GUI -> Compiler m (Key, InstGUI m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1)) (Key
rKey -> Key -> Key
forall a. Num a => a -> a -> a
+[(Maybe (P Expr), GUI)] -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length [(Maybe (P Expr), GUI)]
cs) [GUI]
childwrs
            case Maybe Identifier
k of
              Just Identifier
k' -> Identifier
-> GlobalBinding
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall (m :: * -> *).
MonadBackend m =>
Identifier -> GlobalBinding -> Compiler m ()
defName Identifier
k' (GlobalBinding
 -> RWST
      (CompilerEnv m) (Initialisation m) CompilerState Identity ())
-> GlobalBinding
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ Value -> GlobalBinding
Constant (Value -> GlobalBinding) -> Value -> GlobalBinding
forall a b. (a -> b) -> a -> b
$ WidgetRef -> Value
Reference (Key
lastwr, P Identifier -> Identifier
forall a. P a -> a
unP P Identifier
c, Maybe Identifier
k)
              Maybe Identifier
Nothing -> ()
-> RWST
     (CompilerEnv m) (Initialisation m) CompilerState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Constructor m
c' <- (Identifier -> Compiler m (Constructor m))
-> P Identifier -> Compiler m (Constructor m)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend (ClassMap m -> Identifier -> Compiler m (Constructor m)
forall (m :: * -> *).
ClassMap m -> Identifier -> Compiler m (Constructor m)
lookupClass ClassMap m
m) P Identifier
c
            [Maybe (Execution m Value)]
orients' <- [Maybe (P Expr)]
-> (Maybe (P Expr)
    -> RWST
         (CompilerEnv m)
         (Initialisation m)
         CompilerState
         Identity
         (Maybe (Execution m Value)))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Maybe (Execution m Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Maybe (P Expr)]
orients ((Maybe (P Expr)
  -> RWST
       (CompilerEnv m)
       (Initialisation m)
       CompilerState
       Identity
       (Maybe (Execution m Value)))
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      [Maybe (Execution m Value)])
-> (Maybe (P Expr)
    -> RWST
         (CompilerEnv m)
         (Initialisation m)
         CompilerState
         Identity
         (Maybe (Execution m Value)))
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Maybe (Execution m Value)]
forall a b. (a -> b) -> a -> b
$ (P Expr -> Compiler m (Execution m Value))
-> Maybe (P Expr)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Maybe (Execution m Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((P Expr -> Compiler m (Execution m Value))
 -> Maybe (P Expr)
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Maybe (Execution m Value)))
-> (P Expr -> Compiler m (Execution m Value))
-> Maybe (P Expr)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Maybe (Execution m Value))
forall a b. (a -> b) -> a -> b
$ (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr
            (Key, InstGUI m) -> Compiler m (Key, InstGUI m)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Key
lastwr, WidgetRef
-> Constructor m
-> Map Identifier (Execution m Value)
-> [(Maybe (Execution m Value), InstGUI m)]
-> InstGUI m
forall (m :: * -> *).
WidgetRef
-> Constructor m
-> WidgetArgs m
-> [(Maybe (Execution m Value), InstGUI m)]
-> InstGUI m
InstGUI (Key
r, P Identifier -> Identifier
forall a. P a -> a
unP P Identifier
c, Maybe Identifier
k) Constructor m
c' Map Identifier (Execution m Value)
es'
                               ([(Maybe (Execution m Value), InstGUI m)] -> InstGUI m)
-> [(Maybe (Execution m Value), InstGUI m)] -> InstGUI m
forall a b. (a -> b) -> a -> b
$ [Maybe (Execution m Value)]
-> [InstGUI m] -> [(Maybe (Execution m Value), InstGUI m)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe (Execution m Value)]
orients' [InstGUI m]
children )
                where ([Maybe (P Expr)]
orients, [GUI]
childwrs) = [(Maybe (P Expr), GUI)] -> ([Maybe (P Expr)], [GUI])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe (P Expr), GUI)]
cs

compileProgram :: MonadBackend m => Program ->
                  ClassMap m -> ObjectMap m -> FuncMap m -> GlobMap m
               -> ([SindreOption], Sindre m () , WidgetRef)
compileProgram :: Program
-> ClassMap m
-> ObjectMap m
-> FuncMap m
-> GlobMap m
-> ([SindreOption], Sindre m (), WidgetRef)
compileProgram Program
prog ClassMap m
cm ObjectMap m
om FuncMap m
fm GlobMap m
gm =
  let env :: CompilerEnv m
env = CompilerEnv Any
forall (m :: * -> *). CompilerEnv m
blankCompilerEnv { functionRefs :: Map Identifier (Execution m Value)
functionRefs = Map Identifier (Execution m Value)
funtable }
      ((Map Identifier (Execution m Value)
funtable, EventHandler m
evhandler, [SindreOption]
options, WidgetRef
rootw), Sindre m ()
initialiser) =
        CompilerEnv m
-> Compiler
     m
     (Map Identifier (Execution m Value), EventHandler m,
      [SindreOption], WidgetRef)
-> ((Map Identifier (Execution m Value), EventHandler m,
     [SindreOption], WidgetRef),
    Sindre m ())
forall (m :: * -> *) a.
CompilerEnv m -> Compiler m a -> (a, Initialisation m)
runCompiler CompilerEnv m
env (Compiler
   m
   (Map Identifier (Execution m Value), EventHandler m,
    [SindreOption], WidgetRef)
 -> ((Map Identifier (Execution m Value), EventHandler m,
      [SindreOption], WidgetRef),
     Sindre m ()))
-> Compiler
     m
     (Map Identifier (Execution m Value), EventHandler m,
      [SindreOption], WidgetRef)
-> ((Map Identifier (Execution m Value), EventHandler m,
     [SindreOption], WidgetRef),
    Sindre m ())
forall a b. (a -> b) -> a -> b
$ do
          ((Identifier, m Value)
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> [(Identifier, m Value)]
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Identifier, m Value)
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall (m :: * -> *).
MonadBackend m =>
(Identifier, m Value) -> Compiler m ()
compileBackendGlobal ([(Identifier, m Value)]
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> [(Identifier, m Value)]
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ GlobMap m -> [(Identifier, m Value)]
forall k a. Map k a -> [(k, a)]
M.toList GlobMap m
gm
          [SindreOption]
opts <- (P (Identifier, (SindreOption, Maybe Value))
 -> RWST
      (CompilerEnv m) (Sindre m ()) CompilerState Identity SindreOption)
-> [P (Identifier, (SindreOption, Maybe Value))]
-> RWST
     (CompilerEnv m) (Sindre m ()) CompilerState Identity [SindreOption]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Identifier, (SindreOption, Maybe Value))
 -> RWST
      (CompilerEnv m) (Sindre m ()) CompilerState Identity SindreOption)
-> P (Identifier, (SindreOption, Maybe Value))
-> RWST
     (CompilerEnv m) (Sindre m ()) CompilerState Identity SindreOption
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend (Identifier, (SindreOption, Maybe Value))
-> RWST
     (CompilerEnv m) (Sindre m ()) CompilerState Identity SindreOption
forall (m :: * -> *).
MonadBackend m =>
(Identifier, (SindreOption, Maybe Value))
-> Compiler m SindreOption
compileOption) ([P (Identifier, (SindreOption, Maybe Value))]
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      [SindreOption])
-> [P (Identifier, (SindreOption, Maybe Value))]
-> RWST
     (CompilerEnv m) (Sindre m ()) CompilerState Identity [SindreOption]
forall a b. (a -> b) -> a -> b
$ Program -> [P (Identifier, (SindreOption, Maybe Value))]
programOptions Program
prog
          (P (Identifier, P Expr)
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> [P (Identifier, P Expr)]
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((Identifier, P Expr)
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> P (Identifier, P Expr)
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend (Identifier, P Expr)
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall (m :: * -> *).
MonadBackend m =>
(Identifier, P Expr) -> Compiler m ()
compileGlobal) ([P (Identifier, P Expr)]
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> [P (Identifier, P Expr)]
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ Program -> [P (Identifier, P Expr)]
programGlobals Program
prog
          (Key
lastwr, InstGUI m
gui) <- ClassMap m -> (Maybe (P Expr), GUI) -> Compiler m (Key, InstGUI m)
forall (m :: * -> *).
MonadBackend m =>
ClassMap m -> (Maybe (P Expr), GUI) -> Compiler m (Key, InstGUI m)
compileGUI ClassMap m
cm ((Maybe (P Expr), GUI) -> Compiler m (Key, InstGUI m))
-> (Maybe (P Expr), GUI) -> Compiler m (Key, InstGUI m)
forall a b. (a -> b) -> a -> b
$ Program -> (Maybe (P Expr), GUI)
programGUI Program
prog
          InstObjs m
objs <- Key -> ObjectMap m -> Compiler m (InstObjs m)
forall (m :: * -> *).
MonadBackend m =>
Key -> ObjectMap m -> Compiler m (InstObjs m)
compileObjs (Key
lastwrKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1) ObjectMap m
om
          let lastwr' :: Key
lastwr' = Key
lastwr Key -> Key -> Key
forall a. Num a => a -> a -> a
+ InstObjs m -> Key
forall (t :: * -> *) a. Foldable t => t a -> Key
length InstObjs m
objs
          EventHandler m
handler <- [P (Pattern, Action)] -> Compiler m (EventHandler m)
forall (m :: * -> *).
MonadBackend m =>
[P (Pattern, Action)] -> Compiler m (EventHandler m)
compileActions ([P (Pattern, Action)] -> Compiler m (EventHandler m))
-> [P (Pattern, Action)] -> Compiler m (EventHandler m)
forall a b. (a -> b) -> a -> b
$ Program -> [P (Pattern, Action)]
programActions Program
prog
          Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Sindre m ()
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ do
            [(Key, DataSlot m)]
ws <- InstGUI m -> Sindre m [(Key, DataSlot m)]
forall (m :: * -> *).
MonadBackend m =>
InstGUI m -> Sindre m [(Key, DataSlot m)]
initGUI InstGUI m
gui
            [(Key, DataSlot m)]
os <- InstObjs m -> Sindre m [(Key, DataSlot m)]
forall (m :: * -> *).
MonadBackend m =>
InstObjs m -> Sindre m [(Key, DataSlot m)]
initObjs InstObjs m
objs
            (SindreEnv m -> SindreEnv m) -> Sindre m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SindreEnv m -> SindreEnv m) -> Sindre m ())
-> (SindreEnv m -> SindreEnv m) -> Sindre m ()
forall a b. (a -> b) -> a -> b
$ \SindreEnv m
s -> SindreEnv m
s { objects :: Array Key (DataSlot m)
objects = (Key, Key) -> [(Key, DataSlot m)] -> Array Key (DataSlot m)
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Key
0, Key
lastwr') ([(Key, DataSlot m)] -> Array Key (DataSlot m))
-> [(Key, DataSlot m)] -> Array Key (DataSlot m)
forall a b. (a -> b) -> a -> b
$ [(Key, DataSlot m)]
ws[(Key, DataSlot m)] -> [(Key, DataSlot m)] -> [(Key, DataSlot m)]
forall a. [a] -> [a] -> [a]
++[(Key, DataSlot m)]
os }
          [(Identifier, Execution m Value)]
funs' <- [P (Identifier, Function)]
-> (P (Identifier, Function)
    -> RWST
         (CompilerEnv m)
         (Sindre m ())
         CompilerState
         Identity
         (Identifier, Execution m Value))
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     [(Identifier, Execution m Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [P (Identifier, Function)]
funs ((P (Identifier, Function)
  -> RWST
       (CompilerEnv m)
       (Sindre m ())
       CompilerState
       Identity
       (Identifier, Execution m Value))
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      [(Identifier, Execution m Value)])
-> (P (Identifier, Function)
    -> RWST
         (CompilerEnv m)
         (Sindre m ())
         CompilerState
         Identity
         (Identifier, Execution m Value))
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     [(Identifier, Execution m Value)]
forall a b. (a -> b) -> a -> b
$ ((Identifier, Function)
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Identifier, Execution m Value))
-> P (Identifier, Function)
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend (((Identifier, Function)
  -> RWST
       (CompilerEnv m)
       (Sindre m ())
       CompilerState
       Identity
       (Identifier, Execution m Value))
 -> P (Identifier, Function)
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Identifier, Execution m Value))
-> ((Identifier, Function)
    -> RWST
         (CompilerEnv m)
         (Sindre m ())
         CompilerState
         Identity
         (Identifier, Execution m Value))
-> P (Identifier, Function)
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall a b. (a -> b) -> a -> b
$ \(Identifier
k, Function
f) ->
            case ((P (Identifier, Function) -> Bool)
-> [P (Identifier, Function)] -> [P (Identifier, Function)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
==Identifier
k) (Identifier -> Bool)
-> (P (Identifier, Function) -> Identifier)
-> P (Identifier, Function)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, Function) -> Identifier
forall a b. (a, b) -> a
fst ((Identifier, Function) -> Identifier)
-> (P (Identifier, Function) -> (Identifier, Function))
-> P (Identifier, Function)
-> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. P (Identifier, Function) -> (Identifier, Function)
forall a. P a -> a
unP) [P (Identifier, Function)]
funs,
                  Identifier
-> FuncMap m -> Maybe (Compiler m ([Value] -> Sindre m Value))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k FuncMap m
fm) of
              (P (Identifier, Function)
_:P (Identifier, Function)
_:[P (Identifier, Function)]
_, Maybe (Compiler m ([Value] -> Sindre m Value))
_) -> Identifier
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Identifier, Execution m Value))
-> Identifier
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall a b. (a -> b) -> a -> b
$
                            Identifier
"Multiple definitions of function '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"
              ([P (Identifier, Function)]
_, Just Compiler m ([Value] -> Sindre m Value)
_) -> Identifier
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Identifier, Execution m Value))
-> Identifier
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall a b. (a -> b) -> a -> b
$
                             Identifier
"Redefinition of built-in function '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"
              ([P (Identifier, Function)],
 Maybe (Compiler m ([Value] -> Sindre m Value)))
_        -> do Execution m Value
f' <- Function -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Function -> Compiler m (Execution m Value)
compileFunction Function
f
                             (Identifier, Execution m Value)
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Identifier, Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Identifier
k, Execution m Value
f')
          Map Identifier (Execution m Value)
fm' <- FuncMap m
-> (Compiler m ([Value] -> Sindre m Value)
    -> Compiler m (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Map Identifier (Execution m Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FuncMap m
fm ((Compiler m ([Value] -> Sindre m Value)
  -> Compiler m (Execution m Value))
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Map Identifier (Execution m Value)))
-> (Compiler m ([Value] -> Sindre m Value)
    -> Compiler m (Execution m Value))
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Map Identifier (Execution m Value))
forall a b. (a -> b) -> a -> b
$ \Compiler m ([Value] -> Sindre m Value)
e -> do
            [Value] -> Sindre m Value
e' <- Compiler m ([Value] -> Sindre m Value)
e
            Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ Sindre m Value -> Execution m Value
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Sindre m Value -> Execution m Value)
-> ([Value] -> Sindre m Value) -> [Value] -> Execution m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Sindre m Value
e' ([Value] -> Execution m Value)
-> Execution m [Value] -> Execution m Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IntMap Value -> [Value]
forall a. IntMap a -> [a]
IM.elems (IntMap Value -> [Value])
-> Execution m (IntMap Value) -> Execution m [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sindre m (IntMap Value) -> Execution m (IntMap Value)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre ((SindreEnv m -> IntMap Value) -> Sindre m (IntMap Value)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SindreEnv m -> IntMap Value
forall (m :: * -> *). SindreEnv m -> IntMap Value
execFrame)
          [Execution m ()]
begin <- (P Stmt
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      (Execution m ()))
-> P Stmt
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) ([P Stmt]
 -> RWST
      (CompilerEnv m)
      (Sindre m ())
      CompilerState
      Identity
      [Execution m ()])
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Sindre m ())
     CompilerState
     Identity
     [Execution m ()]
forall a b. (a -> b) -> a -> b
$ Program -> [P Stmt]
programBegin Program
prog
          Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Sindre m ()
 -> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ())
-> Sindre m ()
-> RWST (CompilerEnv m) (Sindre m ()) CompilerState Identity ()
forall a b. (a -> b) -> a -> b
$ Execution m () -> Sindre m ()
forall (m :: * -> *) a.
MonadBackend m =>
Execution m a -> Sindre m ()
execute_ (Execution m () -> Sindre m ()) -> Execution m () -> Sindre m ()
forall a b. (a -> b) -> a -> b
$ Execution m () -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Execution m () -> Execution m ()
nextHere (Execution m () -> Execution m ())
-> Execution m () -> Execution m ()
forall a b. (a -> b) -> a -> b
$ [Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Execution m ()]
begin
          (Map Identifier (Execution m Value), EventHandler m,
 [SindreOption], WidgetRef)
-> Compiler
     m
     (Map Identifier (Execution m Value), EventHandler m,
      [SindreOption], WidgetRef)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Identifier, Execution m Value)]
-> Map Identifier (Execution m Value)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Identifier, Execution m Value)]
funs' Map Identifier (Execution m Value)
-> Map Identifier (Execution m Value)
-> Map Identifier (Execution m Value)
forall k a. Ord k => Map k a -> Map k a -> Map k a
`M.union` Map Identifier (Execution m Value)
fm',
                  EventHandler m
handler, [SindreOption]
opts, InstGUI m -> WidgetRef
forall (m :: * -> *). InstGUI m -> WidgetRef
rootwref InstGUI m
gui)
  in ([SindreOption]
options, Sindre m ()
initialiser Sindre m () -> Sindre m () -> Sindre m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EventHandler m -> Sindre m ()
forall (m :: * -> *).
MonadBackend m =>
EventHandler m -> Sindre m ()
eventLoop EventHandler m
evhandler, WidgetRef
rootw)
    where funs :: [P (Identifier, Function)]
funs = Program -> [P (Identifier, Function)]
programFunctions Program
prog
          rootwref :: InstGUI m -> WidgetRef
rootwref (InstGUI WidgetRef
r Constructor m
_ WidgetArgs m
_ [(Maybe (Execution m Value), InstGUI m)]
_) = WidgetRef
r

compileFunction :: MonadBackend m => Function -> Compiler m (Execution m Value)
compileFunction :: Function -> Compiler m (Execution m Value)
compileFunction (Function [Identifier]
args [P Stmt]
body) =
  (CompilerEnv m -> CompilerEnv m)
-> Compiler m (Execution m Value) -> Compiler m (Execution m Value)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CompilerEnv m
s -> CompilerEnv m
s { lexicalScope :: Map Identifier Key
lexicalScope = Map Identifier Key
argmap }) (Compiler m (Execution m Value) -> Compiler m (Execution m Value))
-> Compiler m (Execution m Value) -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    [Execution m ()]
exs <- (P Stmt
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m ()))
-> P Stmt
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
body
    Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
      [Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Execution m ()]
exs
      Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
falsity
      where argmap :: Map Identifier Key
argmap = [(Identifier, Key)] -> Map Identifier Key
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Identifier, Key)] -> Map Identifier Key)
-> [(Identifier, Key)] -> Map Identifier Key
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Key] -> [(Identifier, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
args [Key
0..]

compileAction :: MonadBackend m => [Identifier] -> Action
              -> Compiler m (Execution m ())
compileAction :: [Identifier] -> Action -> Compiler m (Execution m ())
compileAction [Identifier]
args (StmtAction [P Stmt]
body) =
  (CompilerEnv m -> CompilerEnv m)
-> Compiler m (Execution m ()) -> Compiler m (Execution m ())
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\CompilerEnv m
s -> CompilerEnv m
s { lexicalScope :: Map Identifier Key
lexicalScope = Map Identifier Key
argmap }) (Compiler m (Execution m ()) -> Compiler m (Execution m ()))
-> Compiler m (Execution m ()) -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ do
    [Execution m ()]
exs <- (P Stmt -> Compiler m (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
body
    Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ [Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Execution m ()]
exs
      where argmap :: Map Identifier Key
argmap = [(Identifier, Key)] -> Map Identifier Key
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Identifier, Key)] -> Map Identifier Key)
-> [(Identifier, Key)] -> Map Identifier Key
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [Key] -> [(Identifier, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Identifier]
args [Key
0..]

compilePattern :: MonadBackend m => Pattern
               -> Compiler m ( Event -> Execution m (Maybe [Value])
                             , [Identifier])
compilePattern :: Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
compilePattern (ChordPattern Chord
kp1) = (Event -> Execution m (Maybe [Value]), [Identifier])
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Execution m (Maybe [Value])
forall (m :: * -> *) a. Monad m => Event -> m (Maybe [a])
f, [])
    where f :: Event -> m (Maybe [a])
f (KeyPress Chord
kp2) | Chord
kp1 Chord -> Chord -> Bool
forall a. Eq a => a -> a -> Bool
== Chord
kp2 = Maybe [a] -> m (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [a] -> m (Maybe [a])) -> Maybe [a] -> m (Maybe [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
                           | Bool
otherwise = Maybe [a] -> m (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing
          f Event
_                 = Maybe [a] -> m (Maybe [a])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing
compilePattern (OrPattern Pattern
p1 Pattern
p2) = do
  (Event -> Execution m (Maybe [Value])
p1', [Identifier]
ids1) <- Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *).
MonadBackend m =>
Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
compilePattern Pattern
p1
  (Event -> Execution m (Maybe [Value])
p2', [Identifier]
ids2) <- Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *).
MonadBackend m =>
Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
compilePattern Pattern
p2
  let check :: Event -> Execution m (Maybe [Value])
check Event
ev = do
        Maybe [Value]
v1 <- Event -> Execution m (Maybe [Value])
p1' Event
ev
        Maybe [Value]
v2 <- Event -> Execution m (Maybe [Value])
p2' Event
ev
        Maybe [Value] -> Execution m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> Execution m (Maybe [Value]))
-> Maybe [Value] -> Execution m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ case (Maybe [Value]
v1, Maybe [Value]
v2) of
          (Just [Value]
vs1, Just [Value]
vs2) -> [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ [Value]
vs1[Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++[Value]
vs2
          (Just [Value]
vs1, Maybe [Value]
Nothing)  -> [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs1
          (Maybe [Value]
Nothing, Just [Value]
vs2)  -> [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs2
          (Maybe [Value], Maybe [Value])
_                    -> Maybe [Value]
forall a. Maybe a
Nothing
  (Event -> Execution m (Maybe [Value]), [Identifier])
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Execution m (Maybe [Value])
check, [Identifier]
ids1 [Identifier] -> [Identifier] -> [Identifier]
forall a. [a] -> [a] -> [a]
++ [Identifier]
ids2)
compilePattern (SourcedPattern (NamedSource Identifier
wn Maybe Identifier
fn) Identifier
evn [Identifier]
args) = do
  Value
cv <- Identifier -> Compiler m Value
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m Value
constant Identifier
wn
  case Value
cv of
    Reference WidgetRef
wr -> (Event -> Execution m (Maybe [Value]), [Identifier])
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *) a. Monad m => a -> m a
return (WidgetRef -> Event -> Execution m (Maybe [Value])
forall (m :: * -> *).
Monad m =>
WidgetRef -> Event -> m (Maybe [Value])
f WidgetRef
wr, [Identifier]
args)
    Value
_ -> Identifier
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier
 -> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier]))
-> Identifier
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall a b. (a -> b) -> a -> b
$ Identifier
"'" Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
wn Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
"' is not an object."
    where f :: WidgetRef -> Event -> m (Maybe [Value])
f WidgetRef
wr (NamedEvent Identifier
evn2 [Value]
vs (FieldSrc WidgetRef
wr2 Identifier
fn2))
              | WidgetRef
wr WidgetRef -> WidgetRef -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetRef
wr2, Identifier
evn2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
evn, Identifier
fn2 Identifier -> Maybe Identifier -> Bool
`fcmp` Maybe Identifier
fn = Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> m (Maybe [Value]))
-> Maybe [Value] -> m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs
          f WidgetRef
wr (NamedEvent Identifier
evn2 [Value]
vs (ObjectSrc WidgetRef
wr2))
              | WidgetRef
wr WidgetRef -> WidgetRef -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetRef
wr2, Identifier
evn2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
evn, Maybe Identifier
Nothing <- Maybe Identifier
fn = Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> m (Maybe [Value]))
-> Maybe [Value] -> m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Value]
vs
          f WidgetRef
_ Event
_ = Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Value]
forall a. Maybe a
Nothing
compilePattern (SourcedPattern (GenericSource Identifier
cn Identifier
wn Maybe Identifier
fn) Identifier
evn [Identifier]
args) =
  (Event -> Execution m (Maybe [Value]), [Identifier])
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Execution m (Maybe [Value])
forall (m :: * -> *). Monad m => Event -> m (Maybe [Value])
f, Identifier
wnIdentifier -> [Identifier] -> [Identifier]
forall a. a -> [a] -> [a]
:[Identifier]
args)
    where f :: Event -> m (Maybe [Value])
f (NamedEvent Identifier
evn2 [Value]
vs (FieldSrc wr2 :: WidgetRef
wr2@(Key
_,Identifier
cn2,Maybe Identifier
_) Identifier
fn2))
              | Identifier
cnIdentifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
==Identifier
cn2, Identifier
evn2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
evn, Identifier
fn2 Identifier -> Maybe Identifier -> Bool
`fcmp` Maybe Identifier
fn =
                  Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> m (Maybe [Value]))
-> Maybe [Value] -> m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ WidgetRef -> Value
Reference WidgetRef
wr2 Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
vs
          f (NamedEvent Identifier
evn2 [Value]
vs (ObjectSrc wr2 :: WidgetRef
wr2@(Key
_,Identifier
cn2,Maybe Identifier
_)))
              | Identifier
cnIdentifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
==Identifier
cn2, Identifier
evn2 Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
evn, Maybe Identifier
Nothing <- Maybe Identifier
fn =
                  Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Value] -> m (Maybe [Value]))
-> Maybe [Value] -> m (Maybe [Value])
forall a b. (a -> b) -> a -> b
$ [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ WidgetRef -> Value
Reference WidgetRef
wr2 Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
vs
          f Event
_ = Maybe [Value] -> m (Maybe [Value])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Value]
forall a. Maybe a
Nothing

fcmp :: Identifier -> Maybe Identifier -> Bool
fcmp :: Identifier -> Maybe Identifier -> Bool
fcmp Identifier
f = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool)
-> (Maybe Identifier -> Maybe Bool) -> Maybe Identifier -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> Bool) -> Maybe Identifier -> Maybe Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
==Identifier
f)

compileActions :: MonadBackend m => [P (Pattern, Action)]
               -> Compiler m (EventHandler m)
compileActions :: [P (Pattern, Action)] -> Compiler m (EventHandler m)
compileActions [P (Pattern, Action)]
reacts = do
  [(Event -> Execution m (Maybe [Value]), Execution m ())]
reacts' <- (P (Pattern, Action)
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Event -> Execution m (Maybe [Value]), Execution m ()))
-> [P (Pattern, Action)]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [(Event -> Execution m (Maybe [Value]), Execution m ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Pattern, Action)
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Event -> Execution m (Maybe [Value]), Execution m ()))
-> P (Pattern, Action)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Event -> Execution m (Maybe [Value]), Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend (Pattern, Action)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Event -> Execution m (Maybe [Value]), Execution m ())
forall (m :: * -> *).
MonadBackend m =>
(Pattern, Action)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Event -> Execution m (Maybe [Value]), Execution m ())
compileReaction) [P (Pattern, Action)]
reacts
  EventHandler m -> Compiler m (EventHandler m)
forall (m :: * -> *) a. Monad m => a -> m a
return (EventHandler m -> Compiler m (EventHandler m))
-> EventHandler m -> Compiler m (EventHandler m)
forall a b. (a -> b) -> a -> b
$ \Event
ev -> do Event
-> [(Event -> Execution m (Maybe [Value]), Execution m ())]
-> Execution m ()
forall (t :: * -> *) (m :: * -> *) t.
(Foldable t, MonadBackend m) =>
t
-> t (t -> Execution m (Maybe [Value]), Execution m ())
-> Execution m ()
dispatch Event
ev [(Event -> Execution m (Maybe [Value]), Execution m ())]
reacts'
                     case Event
ev of
                       KeyPress Chord
_ ->
                         (WidgetRef -> EventHandler m)
-> Event -> WidgetRef -> Execution m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip WidgetRef -> EventHandler m
forall (im :: * -> *).
MonadBackend im =>
WidgetRef -> Event -> Execution im ()
recvEventByRef Event
ev (WidgetRef -> Execution m ())
-> Execution m WidgetRef -> Execution m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Sindre m WidgetRef -> Execution m WidgetRef
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre ((SindreEnv m -> WidgetRef) -> Sindre m WidgetRef
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets SindreEnv m -> WidgetRef
forall (m :: * -> *). SindreEnv m -> WidgetRef
kbdFocus)
                       Event
_ -> () -> Execution m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where compileReaction :: (Pattern, Action)
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Event -> Execution m (Maybe [Value]), Execution m ())
compileReaction (Pattern
pat, Action
act) = do
            (Event -> Execution m (Maybe [Value])
pat', [Identifier]
args) <- Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
forall (m :: * -> *).
MonadBackend m =>
Pattern
-> Compiler m (Event -> Execution m (Maybe [Value]), [Identifier])
compilePattern Pattern
pat
            Execution m ()
act'         <- [Identifier] -> Action -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
[Identifier] -> Action -> Compiler m (Execution m ())
compileAction [Identifier]
args Action
act
            (Event -> Execution m (Maybe [Value]), Execution m ())
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Event -> Execution m (Maybe [Value]), Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Event -> Execution m (Maybe [Value])
pat', Execution m ()
act')
          dispatch :: t
-> t (t -> Execution m (Maybe [Value]), Execution m ())
-> Execution m ()
dispatch t
ev = ((t -> Execution m (Maybe [Value]), Execution m ())
 -> Execution m ())
-> t (t -> Execution m (Maybe [Value]), Execution m ())
-> Execution m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((t -> Execution m (Maybe [Value]), Execution m ())
  -> Execution m ())
 -> t (t -> Execution m (Maybe [Value]), Execution m ())
 -> Execution m ())
-> ((t -> Execution m (Maybe [Value]), Execution m ())
    -> Execution m ())
-> t (t -> Execution m (Maybe [Value]), Execution m ())
-> Execution m ()
forall a b. (a -> b) -> a -> b
$ \(t -> Execution m (Maybe [Value])
applies, Execution m ()
apply) -> do
            Maybe [Value]
vs <- t -> Execution m (Maybe [Value])
applies t
ev
            case Maybe [Value]
vs of
              Just [Value]
vs' -> [Value] -> Execution m () -> Execution m ()
forall (m :: * -> *) a.
MonadBackend m =>
[Value] -> Execution m a -> Execution m a
setScope [Value]
vs' Execution m ()
apply
              Maybe [Value]
Nothing  -> () -> Execution m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

compileStmt :: MonadBackend m => Stmt -> Compiler m (Execution m ())
compileStmt :: Stmt -> Compiler m (Execution m ())
compileStmt (Print [P Expr]
xs) = do
  [Execution m Value]
xs' <- (P Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> [P Expr]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr) [P Expr]
xs
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ do
    [Identifier]
vs <- (Value -> Identifier) -> [Value] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Identifier
forall a. Show a => a -> Identifier
show ([Value] -> [Identifier])
-> Execution m [Value] -> Execution m [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Execution m Value] -> Execution m [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Execution m Value]
xs'
    m () -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (m () -> Execution m ()) -> m () -> Execution m ()
forall a b. (a -> b) -> a -> b
$ do
      Identifier -> m ()
forall (m :: * -> *). MonadBackend m => Identifier -> m ()
printVal (Identifier -> m ()) -> Identifier -> m ()
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Identifier
unwords [Identifier]
vs
      Identifier -> m ()
forall (m :: * -> *). MonadBackend m => Identifier -> m ()
printVal Identifier
"\n"
compileStmt (Exit Maybe (P Expr)
Nothing) =
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Initialisation m -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Initialisation m -> Execution m ())
-> Initialisation m -> Execution m ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> Initialisation m
forall (m :: * -> *). MonadBackend m => ExitCode -> Sindre m ()
quitSindre ExitCode
ExitSuccess
compileStmt (Exit (Just P Expr
e)) = do
  Execution m Value
e' <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Identifier -> Execution m ()
bad <- Compiler m (Identifier -> Execution m ())
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
e'
    case Value -> Maybe Integer
forall a. Mold a => Value -> Maybe a
mold Value
v :: Maybe Integer of
      Just Integer
0  -> Initialisation m -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Initialisation m -> Execution m ())
-> Initialisation m -> Execution m ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> Initialisation m
forall (m :: * -> *). MonadBackend m => ExitCode -> Sindre m ()
quitSindre ExitCode
ExitSuccess
      Just Integer
x  -> Initialisation m -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Initialisation m -> Execution m ())
-> Initialisation m -> Execution m ()
forall a b. (a -> b) -> a -> b
$ ExitCode -> Initialisation m
forall (m :: * -> *). MonadBackend m => ExitCode -> Sindre m ()
quitSindre (ExitCode -> Initialisation m) -> ExitCode -> Initialisation m
forall a b. (a -> b) -> a -> b
$ Key -> ExitCode
ExitFailure (Key -> ExitCode) -> Key -> ExitCode
forall a b. (a -> b) -> a -> b
$ Integer -> Key
forall a b. (Integral a, Num b) => a -> b
fi Integer
x
      Maybe Integer
Nothing -> Identifier -> Execution m ()
bad Identifier
"Exit code must be an integer"
compileStmt (Expr P Expr
e) = do
  Execution m Value
e' <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Execution m Value -> Execution m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Execution m Value
e'
compileStmt (Return (Just P Expr
e)) = do
  Execution m Value
e' <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Value -> Execution m ()
forall (m :: * -> *). MonadBackend m => Value -> Execution m ()
doReturn (Value -> Execution m ()) -> Execution m Value -> Execution m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Execution m Value
e'
compileStmt (Return Maybe (P Expr)
Nothing) =
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Value -> Execution m ()
forall (m :: * -> *). MonadBackend m => Value -> Execution m ()
doReturn Value
falsity
compileStmt Stmt
Next = Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return Execution m ()
forall (m :: * -> *). MonadBackend m => Execution m ()
doNext
compileStmt Stmt
Break = Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return Execution m ()
forall (m :: * -> *). MonadBackend m => Execution m ()
doBreak
compileStmt Stmt
Continue = Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return Execution m ()
forall (m :: * -> *). MonadBackend m => Execution m ()
doCont
compileStmt (If P Expr
e [P Stmt]
trueb [P Stmt]
falseb) = do
  Execution m Value
e' <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  [Execution m ()]
trueb' <- (P Stmt -> Compiler m (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
trueb
  [Execution m ()]
falseb' <- (P Stmt -> Compiler m (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
falseb
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
e'
    [Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Execution m ()] -> Execution m ())
-> [Execution m ()] -> Execution m ()
forall a b. (a -> b) -> a -> b
$ if Value -> Bool
true Value
v then [Execution m ()]
trueb' else [Execution m ()]
falseb'
compileStmt (While P Expr
c [P Stmt]
body) =
  Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt (Stmt -> Compiler m (Execution m ()))
-> Stmt -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ P Expr -> P Expr -> P Expr -> [P Stmt] -> Stmt
For P Expr
blank P Expr
c P Expr
blank [P Stmt]
body
    where blank :: P Expr
blank = Value -> Expr
Literal Value
falsity Expr -> P Expr -> P Expr
forall a b. a -> P b -> P a
`at` P Expr
c
compileStmt (For P Expr
e1 P Expr
e2 P Expr
e3 [P Stmt]
body) = do
  [Execution m ()]
body' <- (P Stmt -> Compiler m (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
body
  Execution m Value
e1'   <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e1
  Execution m Value
e2'   <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e2
  Execution m Value
e3'   <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e3
  let stmt :: Execution m ()
stmt = do
        Value
v <- Execution m Value
e2'
        Bool -> Execution m () -> Execution m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Value -> Bool
true Value
v) (Execution m () -> Execution m ())
-> Execution m () -> Execution m ()
forall a b. (a -> b) -> a -> b
$ Execution m () -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Execution m () -> Execution m ()
contHere ([Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Execution m ()]
body') Execution m () -> Execution m Value -> Execution m Value
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Execution m Value
e3' Execution m Value -> Execution m () -> Execution m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Execution m ()
stmt
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Execution m Value
e1' Execution m Value -> Execution m () -> Execution m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Execution m () -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Execution m () -> Execution m ()
breakHere Execution m ()
stmt
compileStmt (Do [P Stmt]
body P Expr
c) = do
  [Execution m ()]
body' <- (P Stmt -> Compiler m (Execution m ()))
-> [P Stmt]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt) [P Stmt]
body
  Execution m ()
loop' <- (Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Stmt -> Compiler m (Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Stmt -> Compiler m (Execution m ())
compileStmt (P Stmt -> Compiler m (Execution m ()))
-> P Stmt -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ P Expr -> [P Stmt] -> Stmt
While P Expr
c [P Stmt]
body Stmt -> P Expr -> P Stmt
forall a b. a -> P b -> P a
`at` P Expr
c
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ Execution m () -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Execution m () -> Execution m ()
breakHere (Execution m () -> Execution m ())
-> Execution m () -> Execution m ()
forall a b. (a -> b) -> a -> b
$ Execution m () -> Execution m ()
forall (m :: * -> *).
MonadBackend m =>
Execution m () -> Execution m ()
contHere ([Execution m ()] -> Execution m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [Execution m ()]
body') Execution m () -> Execution m () -> Execution m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Execution m ()
loop'
compileStmt (Focus P Expr
e) = do
  Execution m Value
e' <- (Expr
 -> RWST
      (CompilerEnv m)
      (Initialisation m)
      CompilerState
      Identity
      (Execution m Value))
-> P Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Identifier -> Execution m ()
bad <- Compiler m (Identifier -> Execution m ())
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m () -> Compiler m (Execution m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m () -> Compiler m (Execution m ()))
-> Execution m () -> Compiler m (Execution m ())
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
e'
    case Value
v of
      Reference WidgetRef
r -> Initialisation m -> Execution m ()
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
Sindre im a -> m im a
sindre (Initialisation m -> Execution m ())
-> Initialisation m -> Execution m ()
forall a b. (a -> b) -> a -> b
$ (SindreEnv m -> SindreEnv m) -> Initialisation m
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((SindreEnv m -> SindreEnv m) -> Initialisation m)
-> (SindreEnv m -> SindreEnv m) -> Initialisation m
forall a b. (a -> b) -> a -> b
$ \SindreEnv m
s -> SindreEnv m
s { kbdFocus :: WidgetRef
kbdFocus = WidgetRef
r }
      Value
_ -> Identifier -> Execution m ()
bad Identifier
"Focus is not a widget reference"

compileExpr :: MonadBackend m => Expr -> Compiler m (Execution m Value)
compileExpr :: Expr -> Compiler m (Execution m Value)
compileExpr (Literal Value
v) = Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
compileExpr (Var Identifier
v) = Identifier -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m (Execution m Value)
value Identifier
v
compileExpr (P SourcePos
_ (Var Identifier
k) `Assign` P Expr
e) = do
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Value -> Execution m ()
set <- Identifier -> Compiler m (Value -> Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m (Value -> Execution m ())
setValue Identifier
k
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
e'
    Value -> Execution m ()
set Value
v
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
compileExpr (Not P Expr
e) = do
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
e'
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ if Value -> Bool
true Value
v then Value
falsity else Value
truth
compileExpr (P Expr
e1 `Equal` P Expr
e2) =
  P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall (m :: * -> *) a.
MonadBackend m =>
P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 ((Value
  -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
 -> Compiler m (Execution m Value))
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ \Value
v1 Value
v2 Identifier -> Execution m Any
_ ->
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$! if Value
v1 Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v2 then Value
truth else Value
falsity
compileExpr (P Expr
e1 `LessThan` P Expr
e2) =
  P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall (m :: * -> *) a.
MonadBackend m =>
P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 ((Value
  -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
 -> Compiler m (Execution m Value))
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ \Value
v1 Value
v2 Identifier -> Execution m Any
_ ->
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$! if Value
v1 Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
< Value
v2 then Value
truth else Value
falsity
compileExpr (P Expr
e1 `LessEql` P Expr
e2) =
  P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall (m :: * -> *) a.
MonadBackend m =>
P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 ((Value
  -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
 -> Compiler m (Execution m Value))
-> (Value
    -> Value -> (Identifier -> Execution m Any) -> Execution m Value)
-> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ \Value
v1 Value
v2 Identifier -> Execution m Any
_ ->
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$! if Value
v1 Value -> Value -> Bool
forall a. Ord a => a -> a -> Bool
<= Value
v2 then Value
truth else Value
falsity
compileExpr (P SourcePos
_ (P SourcePos
_ (Var Identifier
k) `Lookup` P Expr
e1) `Assign` P Expr
e2) = do
  Execution m Value
e1' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e1
  Execution m Value
e2' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e2
  Execution m Value
k'  <- Identifier -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m (Execution m Value)
value Identifier
k
  Value -> Execution m ()
set <- Identifier -> Compiler m (Value -> Execution m ())
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m (Value -> Execution m ())
setValue Identifier
k
  Identifier -> Execution m ()
bad <- Compiler m (Identifier -> Execution m ())
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v1 <- Execution m Value
e1'
    Value
v2 <- Execution m Value
e2'
    Value
o <- Execution m Value
k'
    case Value
o of
      Dict Map Value Value
m ->
          Value -> Execution m ()
set (Value -> Execution m ()) -> Value -> Execution m ()
forall a b. (a -> b) -> a -> b
$! Map Value Value -> Value
Dict (Map Value Value -> Value) -> Map Value Value -> Value
forall a b. (a -> b) -> a -> b
$! Value -> Value -> Map Value Value -> Map Value Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Value
v1 Value
v2 Map Value Value
m
      Value
_ -> Identifier -> Execution m ()
bad Identifier
"Not a dictionary"
    Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v2
compileExpr (P SourcePos
_ (Identifier
s `FieldOf` P Expr
oe) `Assign` P Expr
e) = do
  Execution m Value
oe' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
oe
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Identifier -> Execution m Value
bad <- Compiler m (Identifier -> Execution m Value)
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
o <- Execution m Value
oe'
    Value
v <- Execution m Value
e'
    case Value
o of
      Reference WidgetRef
wr -> do Value
_ <- WidgetRef -> Identifier -> Value -> Execution m Value
forall (im :: * -> *).
MonadBackend im =>
WidgetRef -> Identifier -> Value -> Execution im Value
setFieldByRef WidgetRef
wr Identifier
s Value
v
                         Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
      Value
_            -> Identifier -> Execution m Value
bad Identifier
"Not an object"
compileExpr (P Expr
_ `Assign` P Expr
_) = Identifier -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError Identifier
"Cannot assign to rvalue"
compileExpr (P Expr
e `Lookup` P Expr
fe) = do
  Execution m Value
fe' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
fe
  Execution m Value
e'  <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Identifier -> Execution m Value
bad <- Compiler m (Identifier -> Execution m Value)
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
fe'
    Value
o <- Execution m Value
e'
    case Value
o of
      Dict Map Value Value
m -> Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
falsity (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$! Value -> Map Value Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Value
v Map Value Value
m
      Value
_      -> Identifier -> Execution m Value
bad Identifier
"Not a dictionary"
compileExpr (Identifier
s `FieldOf` P Expr
oe) = do
  Execution m Value
oe' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
oe
  Identifier -> Execution m Value
bad <- Compiler m (Identifier -> Execution m Value)
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
o <- Execution m Value
oe'
    case Value
o of
      Reference WidgetRef
wr -> WidgetRef -> Identifier -> Execution m Value
forall (im :: * -> *).
MonadBackend im =>
WidgetRef -> Identifier -> Execution im Value
getFieldByRef WidgetRef
wr Identifier
s
      Value
_            -> Identifier -> Execution m Value
bad Identifier
"Not an object"
compileExpr (Methcall P Expr
oe Identifier
meth [P Expr]
argexps) = do
  [Execution m Value]
argexps' <- (P Expr -> Compiler m (Execution m Value))
-> [P Expr]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr) [P Expr]
argexps
  Execution m Value
o' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
oe
  Identifier -> Execution m Value
bad <- Compiler m (Identifier -> Execution m Value)
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    [Value]
argvs <- [Execution m Value] -> Execution m [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Execution m Value]
argexps'
    Value
v     <- Execution m Value
o'
    case Value
v of
      Reference WidgetRef
wr -> WidgetRef -> Identifier -> [Value] -> Execution m Value
forall (im :: * -> *).
MonadBackend im =>
WidgetRef -> Identifier -> [Value] -> Execution im Value
callMethodByRef WidgetRef
wr Identifier
meth [Value]
argvs
      Value
_            -> Identifier -> Execution m Value
bad Identifier
"Not an object"
compileExpr (Funcall Identifier
f [P Expr]
argexps) = do
  [Execution m Value]
argexps' <- (P Expr -> Compiler m (Execution m Value))
-> [P Expr]
-> RWST
     (CompilerEnv m)
     (Initialisation m)
     CompilerState
     Identity
     [Execution m Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr) [P Expr]
argexps
  Execution m Value
f' <- Identifier -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Identifier -> Compiler m (Execution m Value)
function Identifier
f
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    [Value]
argv <- [Execution m Value] -> Execution m [Value]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Execution m Value]
argexps'
    [Value] -> Execution m Value -> Execution m Value
forall (m :: * -> *) a.
MonadBackend m =>
[Value] -> Execution m a -> Execution m a
enterScope [Value]
argv (Execution m Value -> Execution m Value)
-> Execution m Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Execution m Value -> Execution m Value
forall (m :: * -> *).
MonadBackend m =>
Execution m Value -> Execution m Value
returnHere Execution m Value
f'
compileExpr (Cond P Expr
c P Expr
trueb P Expr
falseb) = do
  Execution m Value
c' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
c
  Execution m Value
trueb' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
trueb
  Execution m Value
falseb' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
falseb
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v <- Execution m Value
c'
    if Value -> Bool
true Value
v then Execution m Value
trueb' else Execution m Value
falseb'
compileExpr (Concat P Expr
e1 P Expr
e2) = P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
-> Compiler m (Execution m Value)
forall (m :: * -> *) a.
MonadBackend m =>
P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 ((Value
  -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
 -> Compiler m (Execution m Value))
-> (Value
    -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
-> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ \Value
v1 Value
v2 Identifier -> Execution m Value
bad ->
  case (Value -> Maybe Text
forall a. Mold a => Value -> Maybe a
mold Value
v1, Value -> Maybe Text
forall a. Mold a => Value -> Maybe a
mold Value
v2) of
    (Just Text
v1', Just Text
v2') -> Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Text -> Value
StringV (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$! Text
v1' Text -> Text -> Text
`T.append` Text
v2'
    (Maybe Text, Maybe Text)
_ -> Identifier -> Execution m Value
bad Identifier
"Can only concatenate strings"
compileExpr (PostInc P Expr
e) = do
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Execution m Value
p' <- Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr (Expr -> Compiler m (Execution m Value))
-> Expr -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ P Expr
e P Expr -> P Expr -> Expr
`Assign` (P Expr -> P Expr -> Expr
Plus P Expr
e (Value -> Expr
Literal (Double -> Value
Number Double
1) Expr -> P Expr -> P Expr
forall a b. a -> P b -> P a
`at` P Expr
e) Expr -> P Expr -> P Expr
forall a b. a -> P b -> P a
`at` P Expr
e)
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ Execution m Value
e' Execution m Value -> Execution m Value -> Execution m Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Execution m Value
p'
compileExpr (PostDec P Expr
e) = do
  Execution m Value
e' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e
  Execution m Value
p' <- Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr (Expr -> Compiler m (Execution m Value))
-> Expr -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ P Expr
e P Expr -> P Expr -> Expr
`Assign` (P Expr -> P Expr -> Expr
Minus P Expr
e (Value -> Expr
Literal (Double -> Value
Number Double
1) Expr -> P Expr -> P Expr
forall a b. a -> P b -> P a
`at` P Expr
e) Expr -> P Expr -> P Expr
forall a b. a -> P b -> P a
`at` P Expr
e)
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ Execution m Value
e' Execution m Value -> Execution m Value -> Execution m Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Execution m Value
p'
compileExpr (P Expr
e1 `Plus` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Identifier
"add" P Expr
e1 P Expr
e2
compileExpr (P Expr
e1 `Minus` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop (-) Identifier
"subtract" P Expr
e1 P Expr
e2
compileExpr (P Expr
e1 `Times` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) Identifier
"multiply" P Expr
e1 P Expr
e2
compileExpr (P Expr
e1 `Divided` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) Identifier
"divide" P Expr
e1 P Expr
e2
compileExpr (P Expr
e1 `Modulo` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
forall a. Real a => a -> a -> a
mod' Identifier
"take modulo" P Expr
e1 P Expr
e2
compileExpr (P Expr
e1 `RaisedTo` P Expr
e2) = (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
(Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**) Identifier
"exponentiate" P Expr
e1 P Expr
e2

compileBinop :: MonadBackend m =>
                P Expr -> P Expr ->
                (Value -> Value -> (String -> Execution m a)
                 -> Execution m Value)
             -> Compiler m (Execution m Value)
compileBinop :: P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 Value
-> Value -> (Identifier -> Execution m a) -> Execution m Value
op = do
  Execution m Value
e1' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e1
  Execution m Value
e2' <- (Expr -> Compiler m (Execution m Value))
-> P Expr -> Compiler m (Execution m Value)
forall a (m :: * -> *) b.
(a -> Compiler m b) -> P a -> Compiler m b
descend Expr -> Compiler m (Execution m Value)
forall (m :: * -> *).
MonadBackend m =>
Expr -> Compiler m (Execution m Value)
compileExpr P Expr
e2
  Identifier -> Execution m a
bad <- Compiler m (Identifier -> Execution m a)
forall (m :: * -> *) a.
MonadFail m =>
Compiler m (Identifier -> Execution m a)
runtimeError
  Execution m Value -> Compiler m (Execution m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Execution m Value -> Compiler m (Execution m Value))
-> Execution m Value -> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ do
    Value
v1 <- Execution m Value
e1'
    Value
v2 <- Execution m Value
e2'
    Value
-> Value -> (Identifier -> Execution m a) -> Execution m Value
op Value
v1 Value
v2 Identifier -> Execution m a
bad

compileArithop :: MonadBackend m =>
                  (Double -> Double -> Double)
               -> String -> P Expr -> P Expr
               -> Compiler m (Execution m Value)
compileArithop :: (Double -> Double -> Double)
-> Identifier -> P Expr -> P Expr -> Compiler m (Execution m Value)
compileArithop Double -> Double -> Double
op Identifier
opstr P Expr
e1 P Expr
e2 = P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
-> Compiler m (Execution m Value)
forall (m :: * -> *) a.
MonadBackend m =>
P Expr
-> P Expr
-> (Value
    -> Value -> (Identifier -> Execution m a) -> Execution m Value)
-> Compiler m (Execution m Value)
compileBinop P Expr
e1 P Expr
e2 ((Value
  -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
 -> Compiler m (Execution m Value))
-> (Value
    -> Value -> (Identifier -> Execution m Value) -> Execution m Value)
-> Compiler m (Execution m Value)
forall a b. (a -> b) -> a -> b
$ \Value
v1 Value
v2 Identifier -> Execution m Value
bad ->
  case (Value -> Maybe Double
forall a. Mold a => Value -> Maybe a
mold Value
v1, Value -> Maybe Double
forall a. Mold a => Value -> Maybe a
mold Value
v2) of
    (Just Double
v1', Just Double
v2') -> Value -> Execution m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Execution m Value) -> Value -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
Number (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$! Double
v1' Double -> Double -> Double
`op` Double
v2'
    (Maybe Double, Maybe Double)
_ -> Identifier -> Execution m Value
bad (Identifier -> Execution m Value)
-> Identifier -> Execution m Value
forall a b. (a -> b) -> a -> b
$ Identifier
"Can only " Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
opstr Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
" numbers"

type WidgetArgs im = M.Map Identifier (Execution im Value)

-- | Function that, given an initial value, the name of itself if any,
-- and a list of children, yields a computation that constructs a new
-- widget.
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, DataSlot m)]
initGUI :: InstGUI m -> Sindre m [(Key, DataSlot m)]
initGUI (InstGUI r :: WidgetRef
r@(Key
wn,Identifier
_,Maybe Identifier
_) Constructor m
f WidgetArgs m
args [(Maybe (Execution m Value), InstGUI m)]
cs) = do
  Map Identifier Value
args' <- (Execution m Value -> Sindre m Value)
-> WidgetArgs m -> Sindre m (Map Identifier Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Execution m Value -> Sindre m Value
forall (m :: * -> *).
MonadBackend m =>
Execution m Value -> Sindre m Value
execute WidgetArgs m
args
  [(Maybe Value, WidgetRef)]
childrefs <- [(Maybe (Execution m Value), InstGUI m)]
-> ((Maybe (Execution m Value), InstGUI m)
    -> Sindre m (Maybe Value, WidgetRef))
-> Sindre m [(Maybe Value, WidgetRef)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Maybe (Execution m Value), InstGUI m)]
cs (((Maybe (Execution m Value), InstGUI m)
  -> Sindre m (Maybe Value, WidgetRef))
 -> Sindre m [(Maybe Value, WidgetRef)])
-> ((Maybe (Execution m Value), InstGUI m)
    -> Sindre m (Maybe Value, WidgetRef))
-> Sindre m [(Maybe Value, WidgetRef)]
forall a b. (a -> b) -> a -> b
$ \(Maybe (Execution m Value)
e, InstGUI WidgetRef
r' Constructor m
_ WidgetArgs m
_ [(Maybe (Execution m Value), InstGUI m)]
_) -> do
    Maybe Value
v <- case Maybe (Execution m Value)
e of Just Execution m Value
e' -> Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Sindre m Value -> Sindre m (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Execution m Value -> Sindre m Value
forall (m :: * -> *).
MonadBackend m =>
Execution m Value -> Sindre m Value
execute Execution m Value
e'
                   Maybe (Execution m Value)
Nothing -> Maybe Value -> Sindre m (Maybe Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
    (Maybe Value, WidgetRef) -> Sindre m (Maybe Value, WidgetRef)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value
v,WidgetRef
r')
  let constructor :: ConstructorM m (DataSlot m)
constructor = do
        Maybe Integer
minw <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> ConstructorM m Integer -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> ConstructorM m Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
Identifier -> ConstructorM m a
param Identifier
"minwidth"  ConstructorM m (Maybe Integer)
-> ConstructorM m (Maybe Integer) -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer -> ConstructorM m (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        Maybe Integer
minh <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> ConstructorM m Integer -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> ConstructorM m Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
Identifier -> ConstructorM m a
param Identifier
"minheight" ConstructorM m (Maybe Integer)
-> ConstructorM m (Maybe Integer) -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer -> ConstructorM m (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        Maybe Integer
maxw <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> ConstructorM m Integer -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> ConstructorM m Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
Identifier -> ConstructorM m a
param Identifier
"maxwidth"  ConstructorM m (Maybe Integer)
-> ConstructorM m (Maybe Integer) -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer -> ConstructorM m (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        Maybe Integer
maxh <- Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> ConstructorM m Integer -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Identifier -> ConstructorM m Integer
forall a (m :: * -> *).
(Mold a, MonadBackend m) =>
Identifier -> ConstructorM m a
param Identifier
"maxheight" ConstructorM m (Maybe Integer)
-> ConstructorM m (Maybe Integer) -> ConstructorM m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer -> ConstructorM m (Maybe Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Integer
forall a. Maybe a
Nothing
        NewWidget m
nw <- Constructor m
f WidgetRef
r [(Maybe Value, WidgetRef)]
childrefs
        DataSlot m -> ConstructorM m (DataSlot m)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataSlot m -> ConstructorM m (DataSlot m))
-> DataSlot m -> ConstructorM m (DataSlot m)
forall a b. (a -> b) -> a -> b
$ NewWidget m -> Constraints -> DataSlot m
forall (im :: * -> *). NewWidget im -> Constraints -> DataSlot im
instWidget NewWidget m
nw ((Maybe Integer
minw, Maybe Integer
maxw), (Maybe Integer
minh, Maybe Integer
maxh))
  DataSlot m
s <- ConstructorM m (DataSlot m)
-> Map Identifier Value -> Sindre m (DataSlot m)
forall (m :: * -> *) a.
MonadBackend m =>
ConstructorM m a -> Map Identifier Value -> Sindre m a
runConstructor ConstructorM m (DataSlot m)
constructor Map Identifier Value
args'
  [(Key, DataSlot m)]
children <- ([[(Key, DataSlot m)]] -> [(Key, DataSlot m)])
-> Sindre m [[(Key, DataSlot m)]] -> Sindre m [(Key, DataSlot m)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[(Key, DataSlot m)]] -> [(Key, DataSlot m)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Sindre m [[(Key, DataSlot m)]] -> Sindre m [(Key, DataSlot m)])
-> Sindre m [[(Key, DataSlot m)]] -> Sindre m [(Key, DataSlot m)]
forall a b. (a -> b) -> a -> b
$ ((Maybe (Execution m Value), InstGUI m)
 -> Sindre m [(Key, DataSlot m)])
-> [(Maybe (Execution m Value), InstGUI m)]
-> Sindre m [[(Key, DataSlot m)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (InstGUI m -> Sindre m [(Key, DataSlot m)]
forall (m :: * -> *).
MonadBackend m =>
InstGUI m -> Sindre m [(Key, DataSlot m)]
initGUI (InstGUI m -> Sindre m [(Key, DataSlot m)])
-> ((Maybe (Execution m Value), InstGUI m) -> InstGUI m)
-> (Maybe (Execution m Value), InstGUI m)
-> Sindre m [(Key, DataSlot m)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (Execution m Value), InstGUI m) -> InstGUI m
forall a b. (a, b) -> b
snd) [(Maybe (Execution m Value), InstGUI m)]
cs
  [(Key, DataSlot m)] -> Sindre m [(Key, DataSlot m)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Key, DataSlot m)] -> Sindre m [(Key, DataSlot m)])
-> [(Key, DataSlot m)] -> Sindre m [(Key, DataSlot m)]
forall a b. (a -> b) -> a -> b
$ (Key
wn,DataSlot m
s)(Key, DataSlot m) -> [(Key, DataSlot m)] -> [(Key, DataSlot m)]
forall a. a -> [a] -> [a]
:[(Key, DataSlot m)]
children

lookupClass :: ClassMap m -> Identifier -> Compiler m (Constructor m)
lookupClass :: ClassMap m -> Identifier -> Compiler m (Constructor m)
lookupClass ClassMap m
m Identifier
k = Compiler m (Constructor m)
-> (Constructor m -> Compiler m (Constructor m))
-> Maybe (Constructor m)
-> Compiler m (Constructor m)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Compiler m (Constructor m)
forall (m :: * -> *) a. Compiler m a
unknown Constructor m -> Compiler m (Constructor m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Constructor m) -> Compiler m (Constructor m))
-> Maybe (Constructor m) -> Compiler m (Constructor m)
forall a b. (a -> b) -> a -> b
$ Identifier -> ClassMap m -> Maybe (Constructor m)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k ClassMap m
m
    where unknown :: Compiler m a
unknown = Identifier -> Compiler m a
forall (m :: * -> *) a. Identifier -> Compiler m a
compileError (Identifier -> Compiler m a) -> Identifier -> Compiler m a
forall a b. (a -> b) -> a -> b
$ Identifier
"Unknown class '" Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
k Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier
"'"

initObjs :: MonadBackend m =>
            InstObjs m -> Sindre m [(ObjectNum, DataSlot m)]
initObjs :: InstObjs m -> Sindre m [(Key, DataSlot m)]
initObjs = (((Identifier, WidgetRef), WidgetRef -> m (NewObject m))
 -> Sindre m (Key, DataSlot m))
-> InstObjs m -> Sindre m [(Key, DataSlot m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((((Identifier, WidgetRef), WidgetRef -> m (NewObject m))
  -> Sindre m (Key, DataSlot m))
 -> InstObjs m -> Sindre m [(Key, DataSlot m)])
-> (((Identifier, WidgetRef), WidgetRef -> m (NewObject m))
    -> Sindre m (Key, DataSlot m))
-> InstObjs m
-> Sindre m [(Key, DataSlot m)]
forall a b. (a -> b) -> a -> b
$ \((Identifier
_, r :: WidgetRef
r@(Key
r',Identifier
_,Maybe Identifier
_)), WidgetRef -> m (NewObject m)
con) -> do
             NewObject m
no <- m (NewObject m) -> Sindre m (NewObject m)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (m (NewObject m) -> Sindre m (NewObject m))
-> m (NewObject m) -> Sindre m (NewObject m)
forall a b. (a -> b) -> a -> b
$ WidgetRef -> m (NewObject m)
con WidgetRef
r
             (Key, DataSlot m) -> Sindre m (Key, DataSlot m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
r', NewObject m -> DataSlot m
forall (im :: * -> *). NewObject im -> DataSlot im
instObject NewObject m
no)

-- | Class of types that a given backend can convert to from 'Value's.
-- In effect, a monadic version of 'Mold'.
class MonadBackend m => Param m a where
  -- | Attempt to convert the given Sindre value to the relevant
  -- Haskell value.
  moldM :: Value -> m (Maybe a)

data ParamError = NoParam Identifier | BadValue Identifier Value
                  deriving (Key -> ParamError -> Identifier -> Identifier
[ParamError] -> Identifier -> Identifier
ParamError -> Identifier
(Key -> ParamError -> Identifier -> Identifier)
-> (ParamError -> Identifier)
-> ([ParamError] -> Identifier -> Identifier)
-> Show ParamError
forall a.
(Key -> a -> Identifier -> Identifier)
-> (a -> Identifier) -> ([a] -> Identifier -> Identifier) -> Show a
showList :: [ParamError] -> Identifier -> Identifier
$cshowList :: [ParamError] -> Identifier -> Identifier
show :: ParamError -> Identifier
$cshow :: ParamError -> Identifier
showsPrec :: Key -> ParamError -> Identifier -> Identifier
$cshowsPrec :: Key -> ParamError -> Identifier -> Identifier
Show)

instance Error ParamError where
  strMsg :: Identifier -> ParamError
strMsg = (Identifier -> Value -> ParamError)
-> Value -> Identifier -> ParamError
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> Value -> ParamError
BadValue Value
falsity

-- | The monad in which widget construction takes place.  You can only
-- execute this by defining a 'Constructor' that is then used in a
-- Sindre program (see also 'ClassMap').  An example usage could be:
--
-- @
-- myWidget :: 'Constructor' MyBackEnd
-- myWidget w k cs : do
--   -- ConstructorM is an instance of 'Alternative', so we can provide
--   -- defaults or fallbacks for missing parameters.
--   arg <- 'param' \"myParam\" <|> return 12
--   /rest of construction/
-- @
newtype ConstructorM m a = ConstructorM (ErrorT ParamError
                                         (StateT (M.Map Identifier Value)
                                          (Sindre m))
                                         a)
    deriving ( MonadState (M.Map Identifier Value)
             , MonadError ParamError
             , Applicative (ConstructorM m)
a -> ConstructorM m a
Applicative (ConstructorM m)
-> (forall a b.
    ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b)
-> (forall a b.
    ConstructorM m a -> ConstructorM m b -> ConstructorM m b)
-> (forall a. a -> ConstructorM m a)
-> Monad (ConstructorM m)
ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
forall a. a -> ConstructorM m a
forall a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
forall a b.
ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b
forall (m :: * -> *). Applicative (ConstructorM m)
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
forall (m :: * -> *) a. a -> ConstructorM m a
forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
forall (m :: * -> *) a b.
ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b
return :: a -> ConstructorM m a
$creturn :: forall (m :: * -> *) a. a -> ConstructorM m a
>> :: ConstructorM m a -> ConstructorM m b -> ConstructorM m b
$c>> :: forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
>>= :: ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b
$c>>= :: forall (m :: * -> *) a b.
ConstructorM m a -> (a -> ConstructorM m b) -> ConstructorM m b
$cp1Monad :: forall (m :: * -> *). Applicative (ConstructorM m)
Monad, Monad (ConstructorM m)
Monad (ConstructorM m)
-> (forall a. Identifier -> ConstructorM m a)
-> MonadFail (ConstructorM m)
Identifier -> ConstructorM m a
forall a. Identifier -> ConstructorM m a
forall (m :: * -> *). Monad (ConstructorM m)
forall (m :: * -> *).
Monad m -> (forall a. Identifier -> m a) -> MonadFail m
forall (m :: * -> *) a. Identifier -> ConstructorM m a
fail :: Identifier -> ConstructorM m a
$cfail :: forall (m :: * -> *) a. Identifier -> ConstructorM m a
$cp1MonadFail :: forall (m :: * -> *). Monad (ConstructorM m)
MonadFail, a -> ConstructorM m b -> ConstructorM m a
(a -> b) -> ConstructorM m a -> ConstructorM m b
(forall a b. (a -> b) -> ConstructorM m a -> ConstructorM m b)
-> (forall a b. a -> ConstructorM m b -> ConstructorM m a)
-> Functor (ConstructorM m)
forall a b. a -> ConstructorM m b -> ConstructorM m a
forall a b. (a -> b) -> ConstructorM m a -> ConstructorM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> ConstructorM m b -> ConstructorM m a
forall (m :: * -> *) a b.
(a -> b) -> ConstructorM m a -> ConstructorM m b
<$ :: a -> ConstructorM m b -> ConstructorM m a
$c<$ :: forall (m :: * -> *) a b. a -> ConstructorM m b -> ConstructorM m a
fmap :: (a -> b) -> ConstructorM m a -> ConstructorM m b
$cfmap :: forall (m :: * -> *) a b.
(a -> b) -> ConstructorM m a -> ConstructorM m b
Functor, Functor (ConstructorM m)
a -> ConstructorM m a
Functor (ConstructorM m)
-> (forall a. a -> ConstructorM m a)
-> (forall a b.
    ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b)
-> (forall a b c.
    (a -> b -> c)
    -> ConstructorM m a -> ConstructorM m b -> ConstructorM m c)
-> (forall a b.
    ConstructorM m a -> ConstructorM m b -> ConstructorM m b)
-> (forall a b.
    ConstructorM m a -> ConstructorM m b -> ConstructorM m a)
-> Applicative (ConstructorM m)
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
ConstructorM m a -> ConstructorM m b -> ConstructorM m a
ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b
(a -> b -> c)
-> ConstructorM m a -> ConstructorM m b -> ConstructorM m c
forall a. a -> ConstructorM m a
forall a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m a
forall a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
forall a b.
ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b
forall a b c.
(a -> b -> c)
-> ConstructorM m a -> ConstructorM m b -> ConstructorM m c
forall (m :: * -> *). Functor (ConstructorM m)
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *) a. a -> ConstructorM m a
forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m a
forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
forall (m :: * -> *) a b.
ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b
forall (m :: * -> *) a b c.
(a -> b -> c)
-> ConstructorM m a -> ConstructorM m b -> ConstructorM m c
<* :: ConstructorM m a -> ConstructorM m b -> ConstructorM m a
$c<* :: forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m a
*> :: ConstructorM m a -> ConstructorM m b -> ConstructorM m b
$c*> :: forall (m :: * -> *) a b.
ConstructorM m a -> ConstructorM m b -> ConstructorM m b
liftA2 :: (a -> b -> c)
-> ConstructorM m a -> ConstructorM m b -> ConstructorM m c
$cliftA2 :: forall (m :: * -> *) a b c.
(a -> b -> c)
-> ConstructorM m a -> ConstructorM m b -> ConstructorM m c
<*> :: ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b
$c<*> :: forall (m :: * -> *) a b.
ConstructorM m (a -> b) -> ConstructorM m a -> ConstructorM m b
pure :: a -> ConstructorM m a
$cpure :: forall (m :: * -> *) a. a -> ConstructorM m a
$cp1Applicative :: forall (m :: * -> *). Functor (ConstructorM m)
Applicative)

-- | @noParam k@ signals that parameter @k@ is missing.
noParam :: String -> ConstructorM m a
noParam :: Identifier -> ConstructorM m a
noParam = ParamError -> ConstructorM m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParamError -> ConstructorM m a)
-> (Identifier -> ParamError) -> Identifier -> ConstructorM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ParamError
NoParam

-- | @badValue k v@ signals that parameter @k@ is present with value
-- @v@, but that @v@ is an invalid value.
badValue :: String -> Value -> ConstructorM m a
badValue :: Identifier -> Value -> ConstructorM m a
badValue Identifier
k = ParamError -> ConstructorM m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParamError -> ConstructorM m a)
-> (Value -> ParamError) -> Value -> ConstructorM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Value -> ParamError
BadValue Identifier
k

runConstructor :: MonadBackend m => ConstructorM m a
             -> M.Map Identifier Value -> Sindre m a
runConstructor :: ConstructorM m a -> Map Identifier Value -> Sindre m a
runConstructor (ConstructorM ErrorT ParamError (StateT (Map Identifier Value) (Sindre m)) a
c) Map Identifier Value
m = do
  (Either ParamError a
v, Map Identifier Value
m') <- StateT (Map Identifier Value) (Sindre m) (Either ParamError a)
-> Map Identifier Value
-> Sindre m (Either ParamError a, Map Identifier Value)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ErrorT ParamError (StateT (Map Identifier Value) (Sindre m)) a
-> StateT (Map Identifier Value) (Sindre m) (Either ParamError a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT ErrorT ParamError (StateT (Map Identifier Value) (Sindre m)) a
c) Map Identifier Value
m
  case Either ParamError a
v of
    Left (NoParam Identifier
k) -> Identifier -> Sindre m a
forall (m :: * -> *) a. MonadFail m => Identifier -> m a
fail (Identifier -> Sindre m a) -> Identifier -> Sindre m a
forall a b. (a -> b) -> a -> b
$ Identifier
"Missing argument '"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"
    Left (BadValue Identifier
k Value
v') -> Identifier -> Sindre m a
forall (m :: * -> *) a. MonadFail m => Identifier -> m a
fail (Identifier -> Sindre m a) -> Identifier -> Sindre m a
forall a b. (a -> b) -> a -> b
$ Identifier
"Bad value "Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Value -> Identifier
forall a. Show a => a -> Identifier
show Value
v'Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
" for argument '"
                           Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
kIdentifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier
"'"Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++Identifier -> (Value -> Identifier) -> Maybe Value -> Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Identifier
"" ((Identifier
": "Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++) (Identifier -> Identifier)
-> (Value -> Identifier) -> Value -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Identifier
forall a. Show a => a -> Identifier
show) (Identifier -> Map Identifier Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k Map Identifier Value
m)
                              
    Right a
_ | Map Identifier Value
m' Map Identifier Value -> Map Identifier Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Map Identifier Value
forall k a. Map k a
M.empty ->
      Identifier -> Sindre m a
forall (m :: * -> *) a. MonadFail m => Identifier -> m a
fail (Identifier -> Sindre m a) -> Identifier -> Sindre m a
forall a b. (a -> b) -> a -> b
$ Identifier
"Surplus arguments: " Identifier -> Identifier -> Identifier
forall a. [a] -> [a] -> [a]
++ Identifier -> [Identifier] -> Identifier
forall a. [a] -> [[a]] -> [a]
intercalate Identifier
"," (Map Identifier Value -> [Identifier]
forall k a. Map k a -> [k]
M.keys Map Identifier Value
m')
    Right a
v' -> a -> Sindre m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v'

instance MonadBackend m => Alternative (ConstructorM m) where
  empty :: ConstructorM m a
empty = Identifier -> ConstructorM m a
forall (m :: * -> *) a. Identifier -> ConstructorM m a
noParam Identifier
"<none>"
  ConstructorM m a
x <|> :: ConstructorM m a -> ConstructorM m a -> ConstructorM m a
<|> ConstructorM m a
y = ConstructorM m a
x ConstructorM m a
-> (ParamError -> ConstructorM m a) -> ConstructorM m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` ParamError -> ConstructorM m a
f
      where f :: ParamError -> ConstructorM m a
f (NoParam Identifier
k) = ConstructorM m a
y ConstructorM m a
-> (ParamError -> ConstructorM m a) -> ConstructorM m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` Identifier -> ParamError -> ConstructorM m a
forall (m :: * -> *) a.
Identifier -> ParamError -> ConstructorM m a
g Identifier
k
            f (BadValue Identifier
k Value
v) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value -> Bool
true Value
v = ConstructorM m a
y ConstructorM m a
-> (ParamError -> ConstructorM m a) -> ConstructorM m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` Identifier -> ParamError -> ConstructorM m a
forall (m :: * -> *) a.
Identifier -> ParamError -> ConstructorM m a
g Identifier
k
            f ParamError
e                             = ParamError -> ConstructorM m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ParamError
e
            g :: Identifier -> ParamError -> ConstructorM m a
g Identifier
k1 (NoParam  Identifier
_) = Identifier -> ConstructorM m a
forall (m :: * -> *) a. Identifier -> ConstructorM m a
noParam  Identifier
k1
            g Identifier
_  ParamError
e            = ParamError -> ConstructorM m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ParamError
e

instance MonadBackend im => MonadSindre im ConstructorM where
  sindre :: Sindre im a -> ConstructorM im a
sindre = ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a
-> ConstructorM im a
forall (m :: * -> *) a.
ErrorT ParamError (StateT (Map Identifier Value) (Sindre m)) a
-> ConstructorM m a
ConstructorM (ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a
 -> ConstructorM im a)
-> (Sindre im a
    -> ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a)
-> Sindre im a
-> ConstructorM im a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Map Identifier Value) (Sindre im) a
-> ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map Identifier Value) (Sindre im) a
 -> ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a)
-> (Sindre im a -> StateT (Map Identifier Value) (Sindre im) a)
-> Sindre im a
-> ErrorT ParamError (StateT (Map Identifier Value) (Sindre im)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sindre im a -> StateT (Map Identifier Value) (Sindre im) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance (MonadIO m, MonadBackend m) => MonadIO (ConstructorM m) where
  liftIO :: IO a -> ConstructorM m a
liftIO = m a -> ConstructorM m a
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (m a -> ConstructorM m a)
-> (IO a -> m a) -> IO a -> ConstructorM m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io

-- | @k `paramAs` f@ yields the value of the widget parameter @k@,
-- using @f@ to convert it to the proper Haskell type.  If @f@ returns
-- 'Nothing', @'badValue' k @ is called.  If @k@ does not exist,
-- @'noParam' k@ is called.
paramAs :: MonadBackend m =>
           Identifier -> (Value -> Maybe a) -> ConstructorM m a
paramAs :: Identifier -> (Value -> Maybe a) -> ConstructorM m a
paramAs Identifier
k Value -> Maybe a
f = Identifier -> (Value -> m (Maybe a)) -> ConstructorM m a
forall (m :: * -> *) a.
MonadBackend m =>
Identifier -> (Value -> m (Maybe a)) -> ConstructorM m a
paramAsM Identifier
k (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a))
-> (Value -> Maybe a) -> Value -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe a
f)

-- | As 'paramAs', but the conversion function is monadic.
paramAsM :: MonadBackend m => Identifier
         -> (Value -> m (Maybe a)) -> ConstructorM m a
paramAsM :: Identifier -> (Value -> m (Maybe a)) -> ConstructorM m a
paramAsM Identifier
k Value -> m (Maybe a)
mf = do Map Identifier Value
m <- ConstructorM m (Map Identifier Value)
forall s (m :: * -> *). MonadState s m => m s
get
                   case Identifier -> Map Identifier Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Identifier
k Map Identifier Value
m of
                     Maybe Value
Nothing -> Identifier -> ConstructorM m a
forall (m :: * -> *) a. Identifier -> ConstructorM m a
noParam Identifier
k
                     Just Value
v -> do Map Identifier Value -> ConstructorM m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Identifier
k Identifier -> Map Identifier Value -> Map Identifier Value
forall k a. Ord k => k -> Map k a -> Map k a
`M.delete` Map Identifier Value
m)
                                  m (Maybe a) -> ConstructorM m (Maybe a)
forall (im :: * -> *) (m :: (* -> *) -> * -> *) a.
MonadSindre im m =>
im a -> m im a
back (Value -> m (Maybe a)
mf Value
v) ConstructorM m (Maybe a)
-> (Maybe a -> ConstructorM m a) -> ConstructorM m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                     ConstructorM m a
-> (a -> ConstructorM m a) -> Maybe a -> ConstructorM m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Identifier -> Value -> ConstructorM m a
forall (m :: * -> *) a. Identifier -> Value -> ConstructorM m a
badValue Identifier
k Value
v) a -> ConstructorM m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | As 'paramM', but 'moldM' is always used for conversion.
paramM :: (Param m a, MonadBackend m) => Identifier -> ConstructorM m a
paramM :: Identifier -> ConstructorM m a
paramM Identifier
k = Identifier -> (Value -> m (Maybe a)) -> ConstructorM m a
forall (m :: * -> *) a.
MonadBackend m =>
Identifier -> (Value -> m (Maybe a)) -> ConstructorM m a
paramAsM Identifier
k Value -> m (Maybe a)
forall (m :: * -> *) a. Param m a => Value -> m (Maybe a)
moldM

-- | As 'param', but 'mold' is always used for conversion.
param :: (Mold a, MonadBackend m) => Identifier -> ConstructorM m a
param :: Identifier -> ConstructorM m a
param Identifier
k = Identifier -> (Value -> Maybe a) -> ConstructorM m a
forall (m :: * -> *) a.
MonadBackend m =>
Identifier -> (Value -> Maybe a) -> ConstructorM m a
paramAs Identifier
k Value -> Maybe a
forall a. Mold a => Value -> Maybe a
mold