{-# LANGUAGE NoImplicitPrelude #-}

-- | Evaluation of PureScript's expressions used in dead call elimnation.
--
module Language.PureScript.DCE.Eval
  ( evaluate ) where

import Prelude hiding (mod)

import Control.Applicative ((<|>))
import Control.Exception (Exception (..), throw)
import Control.Monad
import Control.Monad.Writer

import Data.List (find)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import qualified Language.PureScript.DCE.Constants as C
import Safe (atMay)

import Language.PureScript.AST.Literals
import Language.PureScript.CoreFn
import Language.PureScript.DCE.Utils
import Language.PureScript.Names (Ident(..), ModuleName(..), Qualified(..), QualifiedBy(..))
import Language.PureScript.PSString


data EvalState
  = NotYet -- ^ an expression has not yet been evaluated
  | Done   -- ^ an expression has been evaluated
  deriving (EvalState -> EvalState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EvalState -> EvalState -> Bool
$c/= :: EvalState -> EvalState -> Bool
== :: EvalState -> EvalState -> Bool
$c== :: EvalState -> EvalState -> Bool
Eq, Int -> EvalState -> ShowS
[EvalState] -> ShowS
EvalState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvalState] -> ShowS
$cshowList :: [EvalState] -> ShowS
show :: EvalState -> String
$cshow :: EvalState -> String
showsPrec :: Int -> EvalState -> ShowS
$cshowsPrec :: Int -> EvalState -> ShowS
Show)


data StackT frame =
    EmptyStack
  | ConsStack !frame !(StackT frame)
  deriving (Int -> StackT frame -> ShowS
forall frame. Show frame => Int -> StackT frame -> ShowS
forall frame. Show frame => [StackT frame] -> ShowS
forall frame. Show frame => StackT frame -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StackT frame] -> ShowS
$cshowList :: forall frame. Show frame => [StackT frame] -> ShowS
show :: StackT frame -> String
$cshow :: forall frame. Show frame => StackT frame -> String
showsPrec :: Int -> StackT frame -> ShowS
$cshowsPrec :: forall frame. Show frame => Int -> StackT frame -> ShowS
Show, forall a b. a -> StackT b -> StackT a
forall a b. (a -> b) -> StackT a -> StackT b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> StackT b -> StackT a
$c<$ :: forall a b. a -> StackT b -> StackT a
fmap :: forall a b. (a -> b) -> StackT a -> StackT b
$cfmap :: forall a b. (a -> b) -> StackT a -> StackT b
Functor)


type Stack = StackT [((Ident, Expr Ann), EvalState)]

-- | Errors thrown by the evaluation.
--
data EvaluationError
    = QualifiedExpresionError Ann (Qualified Ident) ![ModuleName]
    -- ^ qualified expression not found in the list of modules
    | OutOfBoundArrayIndex Ann
    -- ^ out of bound array index
    | NotFoundRecordField Ann PSString
    -- ^ record field not found
  deriving Int -> EvaluationError -> ShowS
[EvaluationError] -> ShowS
EvaluationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EvaluationError] -> ShowS
$cshowList :: [EvaluationError] -> ShowS
show :: EvaluationError -> String
$cshow :: EvaluationError -> String
showsPrec :: Int -> EvaluationError -> ShowS
$cshowsPrec :: Int -> EvaluationError -> ShowS
Show

instance Exception EvaluationError


pushStack :: [(Ident, Expr Ann)]
          -> Stack
          -> Stack
pushStack :: [(Ident, Expr Ann)] -> Stack -> Stack
pushStack [(Ident, Expr Ann)]
frame Stack
st = forall a b. (a -> b) -> [a] -> [b]
map (, EvalState
NotYet) [(Ident, Expr Ann)]
frame forall frame. frame -> StackT frame -> StackT frame
`ConsStack` Stack
st


lookupStack :: Ident
            -> Stack
            -> Maybe ((Ident, Expr Ann), EvalState)
lookupStack :: Ident -> Stack -> Maybe ((Ident, Expr Ann), EvalState)
lookupStack Ident
_i Stack
EmptyStack       = forall a. Maybe a
Nothing
lookupStack Ident
i  (ConsStack [((Ident, Expr Ann), EvalState)]
f Stack
fs) = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\((Ident
i', Expr Ann
_), EvalState
_) -> Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i') [((Ident, Expr Ann), EvalState)]
f of
    Maybe ((Ident, Expr Ann), EvalState)
Nothing -> Ident -> Stack -> Maybe ((Ident, Expr Ann), EvalState)
lookupStack Ident
i Stack
fs
    Just ((Ident, Expr Ann), EvalState)
x  -> forall a. a -> Maybe a
Just ((Ident, Expr Ann), EvalState)
x


-- Mark first found expression as evaluated to avoid infinite loops.
markDone :: Ident -> Stack -> Stack
markDone :: Ident -> Stack -> Stack
markDone Ident
_ Stack
EmptyStack = forall frame. StackT frame
EmptyStack
markDone Ident
i (ConsStack [((Ident, Expr Ann), EvalState)]
l Stack
ls) =
    case forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {b}.
((Ident, b), EvalState)
-> ([((Ident, b), EvalState)], Bool)
-> ([((Ident, b), EvalState)], Bool)
fn ([], Bool
False) [((Ident, Expr Ann), EvalState)]
l of
      ([((Ident, Expr Ann), EvalState)]
l', Bool
True)  -> forall frame. frame -> StackT frame -> StackT frame
ConsStack [((Ident, Expr Ann), EvalState)]
l' Stack
ls
      ([((Ident, Expr Ann), EvalState)]
l', Bool
False) -> forall frame. frame -> StackT frame -> StackT frame
ConsStack [((Ident, Expr Ann), EvalState)]
l' (Ident -> Stack -> Stack
markDone Ident
i Stack
ls)
  where
    fn :: ((Ident, b), EvalState)
-> ([((Ident, b), EvalState)], Bool)
-> ([((Ident, b), EvalState)], Bool)
fn x :: ((Ident, b), EvalState)
x@(a :: (Ident, b)
a@(Ident
i', b
_), EvalState
_) ([((Ident, b), EvalState)]
is, Bool
done)
      | Ident
i forall a. Eq a => a -> a -> Bool
== Ident
i'   = (((Ident, b)
a, EvalState
Done) forall a. a -> [a] -> [a]
: [((Ident, b), EvalState)]
is, Bool
True)
      | Bool
otherwise = (((Ident, b), EvalState)
x         forall a. a -> [a] -> [a]
: [((Ident, b), EvalState)]
is, Bool
done)


-- | Evaluate expressions in a module:
--
-- * @Data.Eq.eq@ of two literals
-- * @Data.Array.index@ on a literal array
-- * Object accessors
-- * Semigroup operations (@Array@, @String@, @Unit@)
-- * Semiring operations (@Unit@, @Unit@, @Unit@)
--
-- Keep stack of local identifiers from @let@ and @case@ expressions, ignoring
-- the ones that are comming from abstractions (we are not reducing
-- applications).
--
evaluate :: [Module Ann] -> [Module Ann]

evaluate :: [Module Ann] -> [Module Ann]
evaluate [Module Ann]
mods = Module Ann -> Module Ann
rewriteModule forall a b. (a -> b) -> [a] -> [b]
`map` [Module Ann]
mods
  where

    rewriteModule :: Module Ann -> Module Ann
    rewriteModule :: Module Ann -> Module Ann
rewriteModule mod :: Module Ann
mod@Module{ ModuleName
moduleName :: forall a. Module a -> ModuleName
moduleName :: ModuleName
moduleName, [Bind Ann]
moduleDecls :: forall a. Module a -> [Bind a]
moduleDecls :: [Bind Ann]
moduleDecls } =
      Module Ann
mod { moduleDecls :: [Bind Ann]
moduleDecls = ModuleName -> Bind Ann -> Bind Ann
rewriteBind ModuleName
moduleName forall a b. (a -> b) -> [a] -> [b]
`map` [Bind Ann]
moduleDecls }


    rewriteBind :: ModuleName
                -> Bind Ann -> Bind Ann
    rewriteBind :: ModuleName -> Bind Ann -> Bind Ann
rewriteBind ModuleName
mn (NonRec Ann
a Ident
i Expr Ann
e) =
      forall a. a -> Ident -> Expr a -> Bind a
NonRec Ann
a Ident
i (ModuleName -> Stack -> Expr Ann -> Expr Ann
rewriteExpr ModuleName
mn forall frame. StackT frame
EmptyStack Expr Ann
e)

    rewriteBind ModuleName
mn (Rec [((Ann, Ident), Expr Ann)]
binds')   =
      forall a. [((a, Ident), Expr a)] -> Bind a
Rec [ ModuleName -> Stack -> Expr Ann -> Expr Ann
rewriteExpr ModuleName
mn Stack
stack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ann, Ident), Expr Ann)
bind'
          | ((Ann, Ident), Expr Ann)
bind' <- [((Ann, Ident), Expr Ann)]
binds' 
          ]
        where
          stack :: Stack
stack = [(Ident, Expr Ann)] -> Stack -> Stack
pushStack ((\((Ann
_, Ident
i), Expr Ann
e) -> (Ident
i, Expr Ann
e)) forall a b. (a -> b) -> [a] -> [b]
`map` [((Ann, Ident), Expr Ann)]
binds')
                            forall frame. StackT frame
EmptyStack


    -- Push identifiers defined in binders onto the stack
    pushBinders :: [Expr Ann] -> [Binder Ann] -> Stack -> Stack
    pushBinders :: [Expr Ann] -> [Binder Ann] -> Stack -> Stack
pushBinders [Expr Ann]
es [Binder Ann]
bs = [(Ident, Expr Ann)] -> Stack -> Stack
pushStack (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)]
fn (forall a b. [a] -> [b] -> [(a, b)]
zip [Binder Ann]
bs [Expr Ann]
es))
      where
        fn :: (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)]
        fn :: (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)]
fn (NullBinder Ann
_, Expr Ann
_ )              = []
        fn (LiteralBinder Ann
_ Literal (Binder Ann)
_, Expr Ann
_)          = []
        fn (VarBinder Ann
_ Ident
i, Expr Ann
e)              = [(Ident
i,Expr Ann
e)]
        fn (ConstructorBinder Ann
_ Qualified (ProperName 'TypeName)
_ Qualified (ProperName 'ConstructorName)
_ [Binder Ann]
as, Expr Ann
e) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)]
fn (forall a b. [a] -> [b] -> [(a, b)]
zip [Binder Ann]
as (forall a. a -> [a]
repeat Expr Ann
e))
        fn (NamedBinder Ann
_ Ident
i Binder Ann
b, Expr Ann
e)          = (Ident
i, Expr Ann
e) forall a. a -> [a] -> [a]
: (Binder Ann, Expr Ann) -> [(Ident, Expr Ann)]
fn (Binder Ann
b, Expr Ann
e)

    -- | Evaluate expressions, keep the stack of local identifiers. It does not
    -- track identifiers which are coming from abstractions, but `Let` and
    -- `Case` binders are pushed into / poped from the stack.
    --
    -- * `Let` binds are added in `onBind` and poped from the stack
    --   when visiting `Let` expression.
    -- * `Case` binds are added in `pushBinders` and poped in the
    --  `everywhereOnValuesM` monadic action.
    --
    rewriteExpr :: ModuleName -> Stack
                -> Expr Ann -> Expr Ann
    rewriteExpr :: ModuleName -> Stack -> Expr Ann -> Expr Ann
rewriteExpr ModuleName
mn Stack
st c :: Expr Ann
c@(Case Ann
ann [Expr Ann]
es [CaseAlternative Ann]
cs) =
        -- purescript is a strict language, so we can take advantage of that
        -- and evalute all the expressions now
        let es' :: [Maybe (Expr Ann)]
            es' :: [Maybe (Expr Ann)]
es' = [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st forall a b. (a -> b) -> [a] -> [b]
`map` [Expr Ann]
es
        in case forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Ann -> Maybe (Expr Ann)
fltLiteral) [Maybe (Expr Ann)]
es' of
          Maybe [Expr Ann]
Nothing ->
            -- remove cases whcich do not match
            forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case Ann
ann [Expr Ann]
es
              forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter
                  ([Maybe (Expr Ann)] -> [Binder Ann] -> Bool
fltBinders ((forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr Ann -> Maybe (Expr Ann)
fltLiteral) forall a b. (a -> b) -> [a] -> [b]
`map` [Maybe (Expr Ann)]
es') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CaseAlternative a -> [Binder a]
caseAlternativeBinders)
                  [CaseAlternative Ann]
cs
          Just [Expr Ann]
es'' ->
            -- all es evaluated to a literal, we can try to find the matching
            -- `CaseAlternative`
            case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([Expr Ann] -> CaseAlternative Ann -> First (CaseAlternative Ann)
fndCase [Expr Ann]
es'') [CaseAlternative Ann]
cs of
              First Maybe (CaseAlternative Ann)
Nothing -> Expr Ann
c
              First (Just (CaseAlternative [Binder Ann]
bs (Right Expr Ann
e)))
                -- we found a matching `CaseAlternative`, we can eliminate the case
                -- expression
                -> ModuleName -> Stack -> Expr Ann -> Expr Ann
rewriteExpr ModuleName
mn ([Expr Ann] -> [Binder Ann] -> Stack -> Stack
pushBinders [Expr Ann]
es'' [Binder Ann]
bs Stack
st) Expr Ann
e
              First (Just (CaseAlternative [Binder Ann]
bs (Left [(Expr Ann, Expr Ann)]
gs)))
                -- we found a matching `CaseAlternative` with guards; we can
                -- simplify the case expression and the list of guards
                -> forall a. a -> [Expr a] -> [CaseAlternative a] -> Expr a
Case Ann
ann [Expr Ann]
es [forall a.
[Binder a]
-> Either [(Guard a, Guard a)] (Guard a) -> CaseAlternative a
CaseAlternative [Binder Ann]
bs (forall a b. a -> Either a b
Left (ModuleName
-> Stack -> [(Expr Ann, Expr Ann)] -> [(Expr Ann, Expr Ann)]
fltGuards ModuleName
mn ([Expr Ann] -> [Binder Ann] -> Stack -> Stack
pushBinders [Expr Ann]
es [Binder Ann]
bs Stack
st) [(Expr Ann, Expr Ann)]
gs))]

    -- todo: evaluate bindings
    rewriteExpr ModuleName
mn Stack
st (Let Ann
ann [Bind Ann]
bs Expr Ann
e) =
       forall a. a -> [Bind a] -> Expr a -> Expr a
Let Ann
ann [Bind Ann]
bs
         (ModuleName -> Stack -> Expr Ann -> Expr Ann
rewriteExpr ModuleName
mn ([(Ident, Expr Ann)] -> Stack -> Stack
pushStack (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Ann -> [(Ident, Expr Ann)]
unBind [Bind Ann]
bs) Stack
st) Expr Ann
e)

    rewriteExpr ModuleName
mn Stack
st e :: Expr Ann
e@Var{} =
      case [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e of
        Just l :: Expr Ann
l@(Literal Ann
_ NumericLiteral{}) -> Expr Ann
l
        Just l :: Expr Ann
l@(Literal Ann
_ CharLiteral{})    -> Expr Ann
l
        Just l :: Expr Ann
l@(Literal Ann
_ BooleanLiteral{}) -> Expr Ann
l
        -- preserve string, array and object literals
        Just Expr Ann
_  -> Expr Ann
e
        Maybe (Expr Ann)
Nothing -> Expr Ann
e

    rewriteExpr ModuleName
mn Stack
st Expr Ann
e =
      case [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e of
        Just Expr Ann
l  -> Expr Ann
l
        Maybe (Expr Ann)
Nothing -> Expr Ann
e

    fltBinders :: [Maybe (Expr Ann)]
               -> [Binder Ann]
               -> Bool
    fltBinders :: [Maybe (Expr Ann)] -> [Binder Ann] -> Bool
fltBinders (Just (Literal Ann
_ Literal (Expr Ann)
l1) : [Maybe (Expr Ann)]
ts) (LiteralBinder Ann
_ Literal (Binder Ann)
l2 : [Binder Ann]
bs) =
      Literal (Expr Ann)
l1 forall a b. Literal a -> Literal b -> Bool
`eqLit` Literal (Binder Ann)
l2 Bool -> Bool -> Bool
&& [Maybe (Expr Ann)] -> [Binder Ann] -> Bool
fltBinders [Maybe (Expr Ann)]
ts [Binder Ann]
bs
    fltBinders [Maybe (Expr Ann)]
_ [Binder Ann]
_ = Bool
True

    fltGuards
      :: ModuleName
      -> Stack
      -> [(Guard Ann, Expr Ann)]
      -> [(Guard Ann, Expr Ann)]
    fltGuards :: ModuleName
-> Stack -> [(Expr Ann, Expr Ann)] -> [(Expr Ann, Expr Ann)]
fltGuards ModuleName
_ Stack
_  [] = []
    fltGuards ModuleName
mn Stack
st (guard' :: (Expr Ann, Expr Ann)
guard'@(Expr Ann
g, Expr Ann
e) : [(Expr Ann, Expr Ann)]
rest) =
      case [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
g of
        Just (Literal Ann
_ Literal (Expr Ann)
t)
          | Literal (Expr Ann)
t forall a b. Literal a -> Literal b -> Bool
`eqLit` forall a. Bool -> Literal a
BooleanLiteral Bool
True
          ->  [(forall a. a -> Literal (Expr a) -> Expr a
Literal (forall a. Expr a -> a
extractAnn Expr Ann
g) (forall a. Bool -> Literal a
BooleanLiteral Bool
True), Expr Ann
e)]
          | Bool
otherwise -- guard expression must evaluate to a Boolean
          -> ModuleName
-> Stack -> [(Expr Ann, Expr Ann)] -> [(Expr Ann, Expr Ann)]
fltGuards ModuleName
mn Stack
st [(Expr Ann, Expr Ann)]
rest
        Maybe (Expr Ann)
_ -> (Expr Ann, Expr Ann)
guard' forall a. a -> [a] -> [a]
: ModuleName
-> Stack -> [(Expr Ann, Expr Ann)] -> [(Expr Ann, Expr Ann)]
fltGuards ModuleName
mn Stack
st [(Expr Ann, Expr Ann)]
rest

    fltLiteral :: Expr Ann -> Maybe (Expr Ann)
    fltLiteral :: Expr Ann -> Maybe (Expr Ann)
fltLiteral e :: Expr Ann
e@Literal {} = forall a. a -> Maybe a
Just Expr Ann
e
    fltLiteral Expr Ann
_            = forall a. Maybe a
Nothing

    -- match a list of literal expressions against a case alternative
    fndCase :: [Expr Ann] -> CaseAlternative Ann -> First (CaseAlternative Ann)
    fndCase :: [Expr Ann] -> CaseAlternative Ann -> First (CaseAlternative Ann)
fndCase [Expr Ann]
as CaseAlternative Ann
c =
        if [Expr Ann]
as [Expr Ann] -> [Binder Ann] -> Bool
`matches` forall a. CaseAlternative a -> [Binder a]
caseAlternativeBinders CaseAlternative Ann
c
          then forall a. Maybe a -> First a
First (forall a. a -> Maybe a
Just CaseAlternative Ann
c)
          else forall a. Maybe a -> First a
First forall a. Maybe a
Nothing
      where
        matches :: [Expr Ann] -> [Binder Ann] -> Bool
        matches :: [Expr Ann] -> [Binder Ann] -> Bool
matches [] [] = Bool
True
        matches [] [Binder Ann]
_  = forall a. HasCallStack => String -> a
error String
"impossible happend: not matching case expressions and case alternatives"
        matches [Expr Ann]
_ []  = forall a. HasCallStack => String -> a
error String
"impossible happend: not matching case expressions and case alternatives"
        matches (Literal Ann
_ Literal (Expr Ann)
t:[Expr Ann]
ts) (LiteralBinder Ann
_ Literal (Binder Ann)
t' : [Binder Ann]
bs) = Literal (Expr Ann)
t forall a b. Literal a -> Literal b -> Bool
`eqLit` Literal (Binder Ann)
t' Bool -> Bool -> Bool
&& [Expr Ann] -> [Binder Ann] -> Bool
matches [Expr Ann]
ts [Binder Ann]
bs
        matches (Literal Ann
_ Literal (Expr Ann)
t:[Expr Ann]
ts) (NamedBinder Ann
_ Ident
_ (LiteralBinder Ann
_ Literal (Binder Ann)
t') : [Binder Ann]
bs) = Literal (Expr Ann)
t forall a b. Literal a -> Literal b -> Bool
`eqLit` Literal (Binder Ann)
t' Bool -> Bool -> Bool
&& [Expr Ann] -> [Binder Ann] -> Bool
matches [Expr Ann]
ts [Binder Ann]
bs
        matches (Literal {}:[Expr Ann]
ts) (Binder Ann
_:[Binder Ann]
bs) = [Expr Ann] -> [Binder Ann] -> Bool
matches [Expr Ann]
ts [Binder Ann]
bs
        matches (Expr Ann
_:[Expr Ann]
_) (Binder Ann
_:[Binder Ann]
_) = Bool
False


-- | Evaluate an expresion
--
-- * `Data.Eq.eq` of two literals
-- * `Data.Array.index` on a literal array
-- * Object accessors
-- * Semigroup operations (Array, String, Unit)
-- * Semiring operations (Int, Number, Unit)
-- * Heyting algebra operations (Boolean, Unit)
--
eval :: [Module Ann]
     -> ModuleName
     -> Stack
     -> Expr Ann
     -> Maybe (Expr Ann)

-- eval _    _  _  _  = Nothing -- TODO: testing without evaluation

eval :: [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st (Var Ann
_ (Qualified (BySourcePos SourcePos
_) Ident
i)) = 
    case Ident -> Stack -> Maybe ((Ident, Expr Ann), EvalState)
lookupStack Ident
i Stack
st of
      Maybe ((Ident, Expr Ann), EvalState)
Nothing               -> forall a. Maybe a
Nothing
      Just ((Ident
_, Expr Ann
e), EvalState
Done)   -> forall a. a -> Maybe a
Just Expr Ann
e
      Just ((Ident
_, Expr Ann
e), EvalState
NotYet) -> [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn (Ident -> Stack -> Stack
markDone Ident
i Stack
st) Expr Ann
e

eval [Module Ann]
mods ModuleName
mn Stack
st (Var Ann
ann qi :: Qualified Ident
qi@(Qualified (ByModuleName ModuleName
imn) Ident
i)) =
    case [Module Ann] -> ModuleName -> Ident -> Maybe LookupResult
lookupQualifiedExpr [Module Ann]
mods ModuleName
imn Ident
i of
      Maybe LookupResult
Nothing             -> forall a e. Exception e => e -> a
throw (Ann -> Qualified Ident -> [ModuleName] -> EvaluationError
QualifiedExpresionError Ann
ann Qualified Ident
qi (forall a. Module a -> ModuleName
moduleName forall a b. (a -> b) -> [a] -> [b]
`map` [Module Ann]
mods))
      Just (FoundExpr Expr Ann
e)  -> [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e
      Just LookupResult
Found          -> forall a. Maybe a
Nothing

eval [Module Ann]
mods ModuleName
mn Stack
st (Literal Ann
ann (ArrayLiteral [Expr Ann]
es)) =
    let es' :: [Expr Ann]
es' = forall a b. (a -> b) -> [a] -> [b]
map (\Expr Ann
e -> forall a. a -> Maybe a -> a
fromMaybe Expr Ann
e forall a b. (a -> b) -> a -> b
$ [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e) [Expr Ann]
es
    in forall a. a -> Maybe a
Just (forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann (forall a. [a] -> Literal a
ArrayLiteral [Expr Ann]
es'))

eval [Module Ann]
mods ModuleName
mn Stack
st (Literal Ann
ann (ObjectLiteral [(PSString, Expr Ann)]
as)) =
    let as' :: [(PSString, Expr Ann)]
as' = forall a b. (a -> b) -> [a] -> [b]
map (\x :: (PSString, Expr Ann)
x@(PSString
n, Expr Ann
e) ->
                    case [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e of
                      Maybe (Expr Ann)
Nothing -> (PSString, Expr Ann)
x
                      Just Expr Ann
e' -> (PSString
n, Expr Ann
e')
                  ) [(PSString, Expr Ann)]
as
    in forall a. a -> Maybe a
Just (forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann (forall a. [(PSString, a)] -> Literal a
ObjectLiteral [(PSString, Expr Ann)]
as'))

eval [Module Ann]
_mods ModuleName
_mn Stack
_st e :: Expr Ann
e@Literal{} = forall a. a -> Maybe a
Just Expr Ann
e

eval [Module Ann]
mods ModuleName
mn Stack
st (Accessor Ann
ann PSString
a (Literal Ann
_ (ObjectLiteral [(PSString, Expr Ann)]
as))) =
    case PSString
a forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(PSString, Expr Ann)]
as of
      -- this cannot happen, unless an unsafe usage of ffi
      Maybe (Expr Ann)
Nothing -> forall a e. Exception e => e -> a
throw (Ann -> PSString -> EvaluationError
NotFoundRecordField Ann
ann PSString
a)
      Just Expr Ann
e  -> [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e

--
-- evaluate boolean operations
--
eval [Module Ann]
mods ModuleName
mn Stack
st
    (App Ann
ann
      (App Ann
_
        (App Ann
_
          (Var Ann
_
            (Qualified
              (ByModuleName ModuleName
C.Eq)
              (Ident Text
"eq")))
          (Var Ann
_ Qualified Ident
inst))
          Expr Ann
e1)
      Expr Ann
e2) =
    if Qualified Ident
inst forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
          [ forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqBoolean")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqInt")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqNumber")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqChar")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqString")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqUnit")
          , forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.eqMod) (Text -> Ident
Ident Text
"eqVoid")
          ]
      then case ([Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e1, [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e2) of
          (Just (Literal Ann
_ Literal (Expr Ann)
l1), Just (Literal Ann
_ Literal (Expr Ann)
l2))
            -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Literal a
BooleanLiteral (forall a b. Literal a -> Literal b -> Bool
eqLit Literal (Expr Ann)
l1 Literal (Expr Ann)
l2)
          (Maybe (Expr Ann), Maybe (Expr Ann))
_ -> forall a. Maybe a
Nothing
      else forall a. Maybe a
Nothing

--
-- evaluate array indexing
--
eval [Module Ann]
mods ModuleName
mn Stack
st
      (App Ann
_
        (App Ann
_
          (Var ann :: Ann
ann@(SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_)
            (Qualified
              (ByModuleName (ModuleName Text
"Data.Array"))
              (Ident Text
"index")))
          (Literal Ann
_ (ArrayLiteral [Expr Ann]
as)))
        (Literal Ann
_ (NumericLiteral (Left Integer
x)))) =
    case ([Expr Ann]
as forall a. [a] -> Int -> Maybe a
`atMay` forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) of
      Maybe (Expr Ann)
Nothing -> forall a e. Exception e => e -> a
throw (Ann -> EvaluationError
OutOfBoundArrayIndex Ann
ann)
      Just Expr Ann
e -> case  [Module Ann] -> ModuleName -> Stack -> Expr Ann -> Maybe (Expr Ann)
eval [Module Ann]
mods ModuleName
mn Stack
st Expr Ann
e of
        Maybe (Expr Ann)
Nothing -> forall a. Maybe a
Nothing
        Just Expr Ann
e' ->
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Expr a -> Expr a -> Expr a
App Ann
ann
                  (forall a. a -> Qualified Ident -> Expr a
Var (SourceSpan
ss, [], forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just (ConstructorType -> [Ident] -> Meta
IsConstructor ConstructorType
SumType [Text -> Ident
Ident Text
"value0"]))
                    (forall a. QualifiedBy -> a -> Qualified a
Qualified
                      (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.maybeMod)
                      (Text -> Ident
Ident Text
"Just")))
                  Expr Ann
e'
--
-- evalualte semigroup operations
--
eval [Module Ann]
_ ModuleName
_ms Stack
_st
    (App Ann
ann
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Semigroup) (Ident Text
"append")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
      | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semigroup) (Text -> Ident
Ident Text
"semigroupArray")
      , Literal Ann
_ (ArrayLiteral [Expr Ann]
a1) <- Expr Ann
e1
      , Literal Ann
_ (ArrayLiteral [Expr Ann]
a2) <- Expr Ann
e2
      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann (forall a. [a] -> Literal a
ArrayLiteral forall a b. (a -> b) -> a -> b
$ [Expr Ann]
a1 forall a. [a] -> [a] -> [a]
++ [Expr Ann]
a2)
      | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semigroup) (Text -> Ident
Ident Text
"semigroupString")
      , Literal Ann
_ (StringLiteral PSString
s1) <- Expr Ann
e1
      , Just Text
t1 <- PSString -> Maybe Text
decodeString PSString
s1
      , Literal Ann
_ (StringLiteral PSString
s2) <- Expr Ann
e2
      , Just Text
t2 <- PSString -> Maybe Text
decodeString PSString
s2
      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal Ann
ann (forall a. PSString -> Literal a
StringLiteral (Text -> PSString
mkString forall a b. (a -> b) -> a -> b
$ Text
t1 forall a. Semigroup a => a -> a -> a
<> Text
t2) )
      | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semigroup) (Text -> Ident
Ident Text
"semigroupUnit")
      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var Ann
ann (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
      | Bool
otherwise
      = forall a. Maybe a
Nothing

--
-- evalulate semiring operations
--
eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Semiring) (Ident Text
"add")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringInt")
    , Literal Ann
_ (NumericLiteral (Left Integer
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Left Integer
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left (Integer
a1 forall a. Num a => a -> a -> a
+ Integer
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringNumber")
    , Literal Ann
_ (NumericLiteral (Right Double
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Right Double
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right (Double
a1 forall a. Num a => a -> a -> a
+ Double
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Semiring) (Ident Text
"zero")))
      (Var Ann
_ Qualified Ident
qi))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringInt")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left Integer
0))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified
        (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring)
        (Text -> Ident
Ident Text
"semiringNumber")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right Double
0.0))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringUnit")
    = forall a. a -> Maybe a
Just  forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Semiring) (Ident Text
"one")))
      (Var Ann
_ Qualified Ident
qi))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringInt")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left Integer
1))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringNumber")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right Double
1.0))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringUnit")
    = forall a. a -> Maybe a
Just  forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Semiring) (Ident Text
"mul")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringInt")
    , Literal Ann
_ (NumericLiteral (Left Integer
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Left Integer
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left (Integer
a1 forall a. Num a => a -> a -> a
* Integer
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringNumber")
    , Literal Ann
_ (NumericLiteral (Right Double
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Right Double
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right (Double
a1 forall a. Num a => a -> a -> a
* Double
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.semiring) (Text -> Ident
Ident Text
"semiringUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

--
-- evaluate ring operations
--
eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
          (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Ring) (Ident Text
"sub")))
          (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"ringInt")
    , Literal Ann
_ (NumericLiteral (Left Integer
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Left Integer
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left (forall a. Integral a => a -> a -> a
quot Integer
a1 Integer
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"ringNumber")
    , Literal Ann
_ (NumericLiteral (Right Double
a1)) <- Expr Ann
e1
    , Literal Ann
_ (NumericLiteral (Right Double
a2)) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right (Double
a1 forall a. Fractional a => a -> a -> a
/ Double
a2)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"unitRing")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))

eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (Var Ann
_ (Qualified (ByModuleName ModuleName
C.Ring) (Ident Text
"negate")))
        (Var Ann
_ Qualified Ident
qi))
      Expr Ann
e)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"ringInt")
    , Literal Ann
_ (NumericLiteral (Left Integer
a)) <- Expr Ann
e
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. a -> Either a b
Left (-Integer
a)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"ringNumber")
    , Literal Ann
_ (NumericLiteral (Right Double
a)) <- Expr Ann
e
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Either Integer Double -> Literal a
NumericLiteral (forall a b. b -> Either a b
Right (-Double
a)))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.ring) (Text -> Ident
Ident Text
"unitRing")
    = forall a. a -> Maybe a
Just  forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))

--
-- evaluate Heyting algebras operations
--
eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"ff")))
      (Var Ann
_ Qualified Ident
qi))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) (forall a. Bool -> Literal a
BooleanLiteral Bool
False)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_ ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"tt")))
      (Var Ann
_ Qualified Ident
qi))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) (forall a. Bool -> Literal a
BooleanLiteral Bool
True)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_mods ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"not")))
        (Var Ann
_ Qualified Ident
qi))
      Expr Ann
e)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    , Literal Ann
_ (BooleanLiteral Bool
b) <- Expr Ann
e
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Bool -> Literal a
BooleanLiteral (Bool -> Bool
not Bool
b))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_mods ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"implies")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    , Literal Ann
_ (BooleanLiteral Bool
b1) <- Expr Ann
e1
    , Literal Ann
_ (BooleanLiteral Bool
b2) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Bool -> Literal a
BooleanLiteral (Bool -> Bool
not Bool
b1 Bool -> Bool -> Bool
&& Bool
b2))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_mods ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"disj")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    , Literal Ann
_ (BooleanLiteral Bool
b1) <- Expr Ann
e1
    , Literal Ann
_ (BooleanLiteral Bool
b2) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Bool -> Literal a
BooleanLiteral (Bool
b1 Bool -> Bool -> Bool
|| Bool
b2))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

eval [Module Ann]
_mods ModuleName
_mn Stack
_st
    (App (SourceSpan
ss, [Comment]
c, Maybe SourceType
_, Maybe Meta
_)
      (App Ann
_
        (App Ann
_
           (Var Ann
_ (Qualified (ByModuleName ModuleName
C.HeytingAlgebra) (Ident Text
"conj")))
           (Var Ann
_ Qualified Ident
qi))
        Expr Ann
e1)
      Expr Ann
e2)
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraBoolean")
    , Literal Ann
_ (BooleanLiteral Bool
b1) <- Expr Ann
e1
    , Literal Ann
_ (BooleanLiteral Bool
b2) <- Expr Ann
e2
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Literal (Expr a) -> Expr a
Literal
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. Bool -> Literal a
BooleanLiteral (Bool
b1 Bool -> Bool -> Bool
&& Bool
b2))
    | Qualified Ident
qi forall a. Eq a => a -> a -> Bool
== forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.heytingAlgebra) (Text -> Ident
Ident Text
"heytingAlgebraUnit")
    = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Qualified Ident -> Expr a
Var
        (SourceSpan
ss, [Comment]
c, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
        (forall a. QualifiedBy -> a -> Qualified a
Qualified (ModuleName -> QualifiedBy
ByModuleName ModuleName
C.unit) (Text -> Ident
Ident Text
"unit"))
    | Bool
otherwise
    = forall a. Maybe a
Nothing

--
-- default case (no evaluation)
--
eval [Module Ann]
_ ModuleName
_ Stack
_ Expr Ann
_ = forall a. Maybe a
Nothing


-- | Lookup result, either with or without the evidence.
-- `Found` marks a found `Prim` value.
data LookupResult =
      FoundExpr !(Expr Ann)
    | Found


-- | Find a qualified name in the list of modules `mods`, return `Found` for
-- `Prim` values, generics and foreign imports, `Right` for found bindings.
--
lookupQualifiedExpr :: [Module Ann]
                    -> ModuleName
                    -> Ident
                    -> Maybe LookupResult
lookupQualifiedExpr :: [Module Ann] -> ModuleName -> Ident -> Maybe LookupResult
lookupQualifiedExpr [Module Ann]
_ (ModuleName Text
mn) Ident
_
    | Text
"Prim" : [Text]
_ <- Text -> Text -> [Text]
T.splitOn Text
"." Text
mn
    = forall a. a -> Maybe a
Just LookupResult
Found
lookupQualifiedExpr [Module Ann]
_ (ModuleName Text
"Data.Generic") (Ident Text
"anyProxy") =
    forall a. a -> Maybe a
Just LookupResult
Found
lookupQualifiedExpr [Module Ann]
mods ModuleName
mn Ident
i =
        (Maybe (Module Ann)
mod forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expr Ann -> LookupResult
FoundExpr
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
i
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Bind Ann -> [(Ident, Expr Ann)]
unBind
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Module a -> [Bind a]
moduleDecls)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe (Module Ann)
mod forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const LookupResult
Found)
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Ident
i)
               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Module a -> [Ident]
moduleForeign)
  where
    mod :: Maybe (Module Ann)
mod = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Module Ann
m -> forall a. Module a -> ModuleName
moduleName Module Ann
m forall a. Eq a => a -> a -> Bool
== ModuleName
mn) [Module Ann]
mods


eqLit :: Literal a -> Literal b -> Bool
eqLit :: forall a b. Literal a -> Literal b -> Bool
eqLit (NumericLiteral (Left Integer
a))  (NumericLiteral (Left Integer
b))  = Integer
a forall a. Eq a => a -> a -> Bool
== Integer
b
eqLit (NumericLiteral (Right Double
a)) (NumericLiteral (Right Double
b)) = Double
a forall a. Eq a => a -> a -> Bool
== Double
b
eqLit (StringLiteral PSString
a)          (StringLiteral PSString
b)          = PSString
a forall a. Eq a => a -> a -> Bool
== PSString
b
eqLit (CharLiteral Char
a)            (CharLiteral Char
b)            = Char
a forall a. Eq a => a -> a -> Bool
== Char
b
eqLit (BooleanLiteral Bool
a)         (BooleanLiteral Bool
b)         = Bool
a forall a. Eq a => a -> a -> Bool
== Bool
b
eqLit Literal a
_                          Literal b
_                          = Bool
False