{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Dickinson.Eval ( EvalSt (..)
                               , addDecl
                               , loadDickinson
                               , evalDickinsonAsMain
                               , resolveExpressionM
                               , resolveDeclarationM
                               , evalExpressionM
                               , evalExpressionAsTextM
                               , findDecl
                               , findMain
                               , lexerStateLens
                               , balanceMax
                               ) where

import           Control.Composition            (thread)
import           Control.Monad                  ((<=<))
import           Control.Monad.Except           (MonadError, throwError)
import qualified Control.Monad.Ext              as Ext
import           Control.Monad.State.Lazy       (MonadState, get, gets, modify, put)
import           Data.Char                      (toUpper)
import           Data.Foldable                  (toList, traverse_)
import qualified Data.IntMap                    as IM
import           Data.List.NonEmpty             (NonEmpty, (<|))
import qualified Data.List.NonEmpty             as NE
import qualified Data.Map                       as M
import qualified Data.Text                      as T
import           Data.Text.Prettyprint.Doc.Ext
import           Language.Dickinson.Error
import           Language.Dickinson.Lexer       hiding (loc)
import           Language.Dickinson.Name
import           Language.Dickinson.Pattern
import           Language.Dickinson.Probability
import           Language.Dickinson.Rename
import           Language.Dickinson.Type
import           Language.Dickinson.TypeCheck
import           Language.Dickinson.Unique
import           Lens.Micro                     (Lens', over, set, _1)
import           Lens.Micro.Mtl                 (modifying, use, (.=))
import           Prettyprinter                  (Doc, Pretty (..), vsep, (<+>))

-- | The state during evaluation
data EvalSt a = EvalSt
    { forall a. EvalSt a -> [Double]
probabilities :: [Double]
    -- map to expression
    , forall a. EvalSt a -> IntMap (Expression a)
boundExpr     :: IM.IntMap (Expression a)
    , forall a. EvalSt a -> Renames
renameCtx     :: Renames
    -- TODO: map to uniques or an expression?
    , forall a. EvalSt a -> Map Text Unique
topLevel      :: M.Map T.Text Unique
    -- Used in the REPL, for instance
    , forall a. EvalSt a -> AlexUserState
lexerState    :: AlexUserState
    , forall a. EvalSt a -> TyEnv a
tyEnv         :: TyEnv a -- ^ For error messages
    , forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors  :: IM.IntMap (NonEmpty (TyName a)) -- ^ This is used for @:pick@ expressions.
    }

instance HasLexerState (EvalSt a) where
    lexerStateLens :: Lens' (EvalSt a) AlexUserState
lexerStateLens AlexUserState -> f AlexUserState
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\AlexUserState
x -> EvalSt a
s { lexerState :: AlexUserState
lexerState = AlexUserState
x }) (AlexUserState -> f AlexUserState
f (forall a. EvalSt a -> AlexUserState
lexerState EvalSt a
s))

prettyBound :: (Int, Expression a) -> Doc b
prettyBound :: forall a b. (Int, Expression a) -> Doc b
prettyBound (Int
i, Expression a
e) = forall a ann. Pretty a => a -> Doc ann
pretty Int
i forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc b
"←" forall ann. Doc ann -> Doc ann -> Doc ann
<#*> forall a ann. Pretty a => a -> Doc ann
pretty Expression a
e

prettyTl :: (T.Text, Unique) -> Doc a
prettyTl :: forall a. (Text, Unique) -> Doc a
prettyTl (Text
t, Unique
i) = forall a ann. Pretty a => a -> Doc ann
pretty Text
t forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc a
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Unique
i

instance Pretty (EvalSt a) where
    pretty :: forall ann. EvalSt a -> Doc ann
pretty (EvalSt [Double]
_ IntMap (Expression a)
b Renames
r Map Text Unique
t AlexUserState
st TyEnv a
_ IntMap (NonEmpty (TyName a))
_) =
        Doc ann
"bound expressions:" forall ann. Doc ann -> Doc ann -> Doc ann
<#> forall ann. [Doc ann] -> Doc ann
vsep (forall a b. (Int, Expression a) -> Doc b
prettyBound forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IntMap a -> [(Int, a)]
IM.toList IntMap (Expression a)
b)
            forall ann. Doc ann -> Doc ann -> Doc ann
<#> forall a ann. Pretty a => a -> Doc ann
pretty Renames
r
            forall ann. Doc ann -> Doc ann -> Doc ann
<#> Doc ann
"top-level names:" forall ann. Doc ann -> Doc ann -> Doc ann
<#> forall ann. [Doc ann] -> Doc ann
vsep (forall a. (Text, Unique) -> Doc a
prettyTl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
M.toList Map Text Unique
t)
            forall ann. Doc ann -> Doc ann -> Doc ann
<#> forall a. AlexUserState -> Doc a
prettyAlexState AlexUserState
st

prettyAlexState :: AlexUserState -> Doc a
prettyAlexState :: forall a. AlexUserState -> Doc a
prettyAlexState (Int
m, [ScdState]
_, Map Text Int
_, NameEnv AlexPosn
nEnv) =
        Doc a
"max:" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Int
m
    forall ann. Doc ann -> Doc ann -> Doc ann
<#> forall b a. Pretty b => IntMap b -> Doc a
prettyDumpBinds NameEnv AlexPosn
nEnv

instance HasRenames (EvalSt a) where
    rename :: Lens' (EvalSt a) Renames
rename Renames -> f Renames
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Renames
x -> EvalSt a
s { renameCtx :: Renames
renameCtx = Renames
x }) (Renames -> f Renames
f (forall a. EvalSt a -> Renames
renameCtx EvalSt a
s))

instance HasTyEnv EvalSt where
    tyEnvLens :: forall a. Lens' (EvalSt a) (IntMap (DickinsonTy a))
tyEnvLens = (\TyEnv a -> f (TyEnv a)
f EvalSt a
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TyEnv a
x -> EvalSt a
s { tyEnv :: TyEnv a
tyEnv = TyEnv a
x }) (TyEnv a -> f (TyEnv a)
f (forall a. EvalSt a -> TyEnv a
tyEnv EvalSt a
s))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
HasTyEnv f =>
Lens' (f a) (IntMap (DickinsonTy a))
tyEnvLens

probabilitiesLens :: Lens' (EvalSt a) [Double]
probabilitiesLens :: forall a. Lens' (EvalSt a) [Double]
probabilitiesLens [Double] -> f [Double]
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Double]
x -> EvalSt a
s { probabilities :: [Double]
probabilities = [Double]
x }) ([Double] -> f [Double]
f (forall a. EvalSt a -> [Double]
probabilities EvalSt a
s))

boundExprLens :: Lens' (EvalSt a) (IM.IntMap (Expression a))
boundExprLens :: forall a. Lens' (EvalSt a) (IntMap (Expression a))
boundExprLens IntMap (Expression a) -> f (IntMap (Expression a))
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntMap (Expression a)
x -> EvalSt a
s { boundExpr :: IntMap (Expression a)
boundExpr = IntMap (Expression a)
x }) (IntMap (Expression a) -> f (IntMap (Expression a))
f (forall a. EvalSt a -> IntMap (Expression a)
boundExpr EvalSt a
s))

constructorsLens :: Lens' (EvalSt a) (IM.IntMap (NonEmpty (TyName a)))
constructorsLens :: forall a. Lens' (EvalSt a) (IntMap (NonEmpty (TyName a)))
constructorsLens IntMap (NonEmpty (TyName a)) -> f (IntMap (NonEmpty (TyName a)))
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntMap (NonEmpty (TyName a))
x -> EvalSt a
s { constructors :: IntMap (NonEmpty (TyName a))
constructors = IntMap (NonEmpty (TyName a))
x }) (IntMap (NonEmpty (TyName a)) -> f (IntMap (NonEmpty (TyName a)))
f (forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors EvalSt a
s))

topLevelLens :: Lens' (EvalSt a) (M.Map T.Text Unique)
topLevelLens :: forall a. Lens' (EvalSt a) (Map Text Unique)
topLevelLens Map Text Unique -> f (Map Text Unique)
f EvalSt a
s = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map Text Unique
x -> EvalSt a
s { topLevel :: Map Text Unique
topLevel = Map Text Unique
x }) (Map Text Unique -> f (Map Text Unique)
f (forall a. EvalSt a -> Map Text Unique
topLevel EvalSt a
s))

nameMod :: Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod :: forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod (Name NonEmpty Text
_ (Unique Int
u) a
_) Expression a
e = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. Lens' (EvalSt a) (IntMap (Expression a))
boundExprLens (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
u Expression a
e)

bindName :: (MonadState (EvalSt a) m) => Name a -> Expression a -> m ()
bindName :: forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> Expression a -> m ()
bindName Name a
n Expression a
e = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e)

topLevelMod :: Name a -> EvalSt a -> EvalSt a
topLevelMod :: forall a. Name a -> EvalSt a -> EvalSt a
topLevelMod (Name NonEmpty Text
n Unique
u a
_) = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. Lens' (EvalSt a) (Map Text Unique)
topLevelLens (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (Text -> [Text] -> Text
T.intercalate Text
"." forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Text
n) Unique
u)

topLevelAdd :: (MonadState (EvalSt a) m) => Name a -> m ()
topLevelAdd :: forall a (m :: * -> *). MonadState (EvalSt a) m => Name a -> m ()
topLevelAdd Name a
n = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Name a -> EvalSt a -> EvalSt a
topLevelMod Name a
n)

tryLookupName :: (MonadState (EvalSt a) m) => Name a -> m (Maybe (Expression a))
tryLookupName :: forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> m (Maybe (Expression a))
tryLookupName (Name NonEmpty Text
_ (Unique Int
u) a
_) = forall {f :: * -> *} {s} {a}.
(MonadState s f, HasRenames s) =>
Maybe (Expression a) -> f (Maybe (Expression a))
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
uforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. EvalSt a -> IntMap (Expression a)
boundExpr)
    where go :: Maybe (Expression a) -> f (Maybe (Expression a))
go (Just Expression a
x) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> {-# SCC "renameClone" #-} forall s (m :: * -> *) a.
(MonadState s m, HasRenames s) =>
Expression a -> m (Expression a)
renameExpressionM Expression a
x
          go Maybe (Expression a)
Nothing  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

lookupName :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Name a -> m (Expression a)
lookupName :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Name a -> m (Expression a)
lookupName n :: Name a
n@(Name NonEmpty Text
_ Unique
_ a
l) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. m a
err forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> m (Maybe (Expression a))
tryLookupName Name a
n
    where err :: m a
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. a -> Name a -> DickinsonError a
UnfoundName a
l Name a
n)

normalize :: (Foldable t, Functor t, Fractional a) => t a -> t a
normalize :: forall (t :: * -> *) a.
(Foldable t, Functor t, Fractional a) =>
t a -> t a
normalize t a
xs = {-# SCC "normalize" #-} (forall a. Fractional a => a -> a -> a
/a
tot) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t a
xs
    where tot :: a
tot = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum t a
xs

cdf :: (Num a) => NonEmpty a -> [a]
cdf :: forall a. Num a => NonEmpty a -> [a]
cdf = {-# SCC "cdf" #-} forall a. Int -> NonEmpty a -> [a]
NE.drop Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl forall a. Num a => a -> a -> a
(+) a
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
0 forall a. a -> NonEmpty a -> NonEmpty a
<|)

pick :: (MonadState (EvalSt a) m) => NonEmpty (Double, Expression a) -> m (Expression a)
pick :: forall a (m :: * -> *).
MonadState (EvalSt a) m =>
NonEmpty (Double, Expression a) -> m (Expression a)
pick NonEmpty (Double, Expression a)
brs = {-# SCC "pick" #-} do
    Double
threshold <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. [a] -> a
headforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. EvalSt a -> [Double]
probabilities)
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. Lens' (EvalSt a) [Double]
probabilitiesLens forall a. [a] -> [a]
tail)
    let ds :: [Double]
ds = forall a. Num a => NonEmpty a -> [a]
cdf (forall (t :: * -> *) a.
(Foldable t, Functor t, Fractional a) =>
t a -> t a
normalize (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
brs))
        es :: [Expression a]
es = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
brs)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Ord a => a -> a -> Bool
<= Double
threshold) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
ds [Expression a]
es

findDecl :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => T.Text -> m (Expression a)
findDecl :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Text -> m (Expression a)
findDecl Text
t = do
    Map Text Unique
tops <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> Map Text Unique
topLevel
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
t Map Text Unique
tops of
        Just (Unique Int
i) -> do { IntMap (Expression a)
es <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> IntMap (Expression a)
boundExpr ; forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntMap (Expression a)
es forall a. IntMap a -> Int -> a
IM.! Int
i) }
        Maybe Unique
Nothing         -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. Text -> DickinsonError a
NoText Text
t)

findMain :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => m (Expression a)
findMain :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
m (Expression a)
findMain = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Text -> m (Expression a)
findDecl Text
"main"

evalDickinsonAsMain :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m)
                    => [Declaration a]
                    -> m T.Text
evalDickinsonAsMain :: forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
[Declaration a] -> m Text
evalDickinsonAsMain [Declaration a]
d =
    forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
[Declaration a] -> m ()
loadDickinson [Declaration a]
d forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    (forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m Text
evalExpressionAsTextM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
m (Expression a)
findMain)

loadDickinson :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m)
              => [Declaration a]
              -> m ()
loadDickinson :: forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
[Declaration a] -> m ()
loadDickinson = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Declaration a -> m ()
addDecl

-- Used in the REPL
balanceMax :: (HasRenames s, HasLexerState s) => MonadState s m => m ()
balanceMax :: forall s (m :: * -> *).
(HasRenames s, HasLexerState s, MonadState s m) =>
m ()
balanceMax = do
    Int
m0 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall a. HasRenames a => Lens' a Renames
renameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Renames Int
maxLens)
    Int
m1 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall a. HasLexerState a => Lens' a AlexUserState
lexerStateLensforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field1 s t a b => Lens s t a b
_1)
    let m' :: Int
m' = forall a. Ord a => a -> a -> a
max Int
m0 Int
m1
    forall a. HasRenames a => Lens' a Renames
renameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Renames Int
maxLens forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
m'
    forall a. HasLexerState a => Lens' a AlexUserState
lexerStateLensforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s t a b. Field1 s t a b => Lens s t a b
_1 forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int
m'

addDecl :: (MonadState (EvalSt a) m)
        => Declaration a
        -> m ()
addDecl :: forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Declaration a -> m ()
addDecl (Define a
_ Name a
n Expression a
e)                      = forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> Expression a -> m ()
bindName Name a
n Expression a
e forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a (m :: * -> *). MonadState (EvalSt a) m => Name a -> m ()
topLevelAdd Name a
n
addDecl (TyDecl a
_ (Name NonEmpty Text
_ (Unique Int
k) a
_) NonEmpty (Name a)
cs) = forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying forall a. Lens' (EvalSt a) (IntMap (NonEmpty (TyName a)))
constructorsLens (forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
k NonEmpty (Name a)
cs)

extrText :: (HasTyEnv s, MonadState (s a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text
extrText :: forall (s :: * -> *) a (m :: * -> *).
(HasTyEnv s, MonadState (s a) m,
 MonadError (DickinsonError a) m) =>
Expression a -> m Text
extrText (Literal a
_ Text
t)  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
extrText (StrChunk a
_ Text
t) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
extrText Expression a
e              = do { DickinsonTy a
ty <- forall (s :: * -> *) a (m :: * -> *).
(HasTyEnv s, MonadState (s a) m,
 MonadError (DickinsonError a) m) =>
Expression a -> m (DickinsonTy a)
typeOf Expression a
e ; forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a.
Expression a -> DickinsonTy a -> DickinsonTy a -> DickinsonError a
TypeMismatch Expression a
e (forall a. a -> DickinsonTy a
TyText forall a b. (a -> b) -> a -> b
$ forall a. Expression a -> a
exprAnn Expression a
e) DickinsonTy a
ty }

-- Work with a temporary state, handling the max sensibly so as to prevent name
-- collisions
withSt :: (HasRenames s, MonadState s m) => (s -> s) -> m b -> m b
withSt :: forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt s -> s
modSt m b
act = do
    s
preSt <- forall s (m :: * -> *). MonadState s m => m s
get
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify s -> s
modSt
    b
res <- m b
act
    Int
postMax <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall a. HasRenames a => Lens' a Renames
renameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Renames Int
maxLens)
    forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall s t a b. ASetter s t a b -> b -> s -> t
set (forall a. HasRenames a => Lens' a Renames
renameforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Renames Int
maxLens) Int
postMax s
preSt)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure b
res

bindPattern :: (MonadError (DickinsonError a) m, MonadState (EvalSt a) m) => Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)
bindPattern :: forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)
bindPattern (PatternVar a
_ Name a
n) Expression a
e               = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e
bindPattern Wildcard{} Expression a
_                     = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
bindPattern PatternCons{} Expression a
_                  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
bindPattern OrPattern{} Expression a
_                    = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
bindPattern (PatternTuple a
_ NonEmpty (Pattern a)
ps) (Tuple a
_ NonEmpty (Expression a)
es) = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)
Ext.zipWithM forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)
bindPattern NonEmpty (Pattern a)
ps NonEmpty (Expression a)
es -- don't need to verify length because in theory typechecker already did
bindPattern (PatternTuple a
l NonEmpty (Pattern a)
_) Expression a
_             = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a. a -> DickinsonError a
MalformedTuple a
l

-- To partially apply lambdas (needed for curried functions)
tryEvalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)
tryEvalExpressionM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM e :: Expression a
e@Literal{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
tryEvalExpressionM e :: Expression a
e@StrChunk{}   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
tryEvalExpressionM e :: Expression a
e@BuiltinFn{}  = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
tryEvalExpressionM v :: Expression a
v@(Var a
_ Name a
n)    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
v) forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> m (Maybe (Expression a))
tryLookupName Name a
n
tryEvalExpressionM (Choice a
_ NonEmpty (Double, Expression a)
pes) = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
MonadState (EvalSt a) m =>
NonEmpty (Double, Expression a) -> m (Expression a)
pick NonEmpty (Double, Expression a)
pes
tryEvalExpressionM (Tuple a
l NonEmpty (Expression a)
es)   = forall a. a -> NonEmpty (Expression a) -> Expression a
Tuple a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM NonEmpty (Expression a)
es
tryEvalExpressionM (Lambda a
l Name a
n DickinsonTy a
ty Expression a
e) = forall a.
a -> Name a -> DickinsonTy a -> Expression a -> Expression a
Lambda a
l Name a
n DickinsonTy a
ty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e
tryEvalExpressionM (Annot a
l Expression a
e DickinsonTy a
ty) = forall a. a -> Expression a -> DickinsonTy a -> Expression a
Annot a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DickinsonTy a
ty
tryEvalExpressionM (Flatten a
l Expression a
e)  = forall a. a -> Expression a -> Expression a
Flatten a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e
tryEvalExpressionM (Apply a
l Expression a
e Expression a
e') = do
    Expression a
e'' <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e
    case Expression a
e'' of
        Lambda a
_ Name a
n DickinsonTy a
_ Expression a
e''' ->
            forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt (forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e') forall a b. (a -> b) -> a -> b
$
                forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e'''
        BuiltinFn a
l' Builtin
b ->
            forall a. a -> Expression a -> Expression a -> Expression a
Apply a
l (forall a. a -> Builtin -> Expression a
BuiltinFn a
l' Builtin
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e'
        Expression a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Expression a -> Expression a -> Expression a
Apply a
l Expression a
e'' Expression a
e
tryEvalExpressionM (Interp a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Interp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM [Expression a]
es
tryEvalExpressionM (MultiInterp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
MultiInterp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM [Expression a]
es
tryEvalExpressionM (Concat a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Concat a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM [Expression a]
es
tryEvalExpressionM c :: Expression a
c@Constructor{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
c
tryEvalExpressionM (Bind a
_ NonEmpty (Name a, Expression a)
bs Expression a
e)       = do
    let ns :: NonEmpty (Name a)
ns = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs
    NonEmpty (Expression a)
newBs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs)
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Name a)
ns NonEmpty (Expression a)
newBs)
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e
tryEvalExpressionM (Let a
_ NonEmpty (Name a, Expression a)
bs Expression a
e)       = do
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) NonEmpty (Name a, Expression a)
bs
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e
tryEvalExpressionM (Match a
l Expression a
e NonEmpty (Pattern a, Expression a)
brs) = do
    let ps :: NonEmpty (Pattern a)
ps = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Pattern a, Expression a)
brs
    NonEmpty (Expression a)
es <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (Pattern a, Expression a)
brs
    forall a.
a
-> Expression a
-> NonEmpty (Pattern a, Expression a)
-> Expression a
Match a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Pattern a)
ps NonEmpty (Expression a)
es)
tryEvalExpressionM (Random a
_ n :: Name a
n@(Name NonEmpty Text
_ (Unique Int
k) a
l)) = do
    IntMap (NonEmpty (Name a))
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors
    case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap (NonEmpty (Name a))
cs of
        Just NonEmpty (Name a)
ns -> forall a (m :: * -> *).
MonadState (EvalSt a) m =>
NonEmpty (Double, Expression a) -> m (Expression a)
pick (forall a. NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors NonEmpty (Name a)
ns)
        Maybe (NonEmpty (Name a))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. a -> Name a -> DickinsonError a
UnfoundType a
l Name a
n)

evalExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)
evalExpressionM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM e :: Expression a
e@Literal{}     = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
evalExpressionM e :: Expression a
e@StrChunk{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
evalExpressionM e :: Expression a
e@BuiltinFn{}   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
evalExpressionM e :: Expression a
e@Constructor{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
evalExpressionM (Var a
_ Name a
n)       = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Name a -> m (Expression a)
lookupName Name a
n
evalExpressionM (Choice a
_ NonEmpty (Double, Expression a)
pes)  = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
MonadState (EvalSt a) m =>
NonEmpty (Double, Expression a) -> m (Expression a)
pick NonEmpty (Double, Expression a)
pes
evalExpressionM (MultiInterp a
l [Expression a]
es) = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
(Text -> Text) -> a -> [Expression a] -> m (Expression a)
concatOrFail (Text -> Text
T.tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.init) a
l [Expression a]
es
evalExpressionM (Interp a
l [Expression a]
es)   = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
(Text -> Text) -> a -> [Expression a] -> m (Expression a)
concatOrFail forall a. a -> a
id a
l [Expression a]
es
evalExpressionM (Concat a
l [Expression a]
es)   = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
(Text -> Text) -> a -> [Expression a] -> m (Expression a)
concatOrFail forall a. a -> a
id a
l [Expression a]
es
evalExpressionM (Tuple a
l NonEmpty (Expression a)
es)    = forall a. a -> NonEmpty (Expression a) -> Expression a
Tuple a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM NonEmpty (Expression a)
es
evalExpressionM (Let a
_ NonEmpty (Name a, Expression a)
bs Expression a
e) = do
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) NonEmpty (Name a, Expression a)
bs
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e
evalExpressionM (Bind a
_ NonEmpty (Name a, Expression a)
bs Expression a
e) = do
    let ns :: NonEmpty (Name a)
ns = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs
    NonEmpty (Expression a)
newBs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs)
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Name a)
ns NonEmpty (Expression a)
newBs)
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e
evalExpressionM (Apply a
_ Expression a
e Expression a
e') = do
    Expression a
e'' <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e
    case Expression a
e'' of
        Lambda a
_ Name a
n DickinsonTy a
_ Expression a
e''' ->
            forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt (forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e') forall a b. (a -> b) -> a -> b
$
                forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
tryEvalExpressionM Expression a
e''' -- tryEvalExpressionM is a special function to "pull" eval through lambdas...
        BuiltinFn a
_ Builtin
b ->
            forall a. (Text -> Text) -> Expression a -> Expression a
mapText (Builtin -> Text -> Text
applyBuiltin Builtin
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e'
        Expression a
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Ill-typed expression"
evalExpressionM e :: Expression a
e@Lambda{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
evalExpressionM (Match a
l Expression a
e NonEmpty (Pattern a, Expression a)
brs) = do
    Expression a
eEval <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e
    (Pattern a
p, Expression a
e') <- forall a (m :: * -> *).
MonadError (DickinsonError a) m =>
a
-> Expression a
-> [(Pattern a, Expression a)]
-> m (Pattern a, Expression a)
matchPattern a
l Expression a
eEval (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Pattern a, Expression a)
brs)
    EvalSt a -> EvalSt a
modSt <- forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)
bindPattern Pattern a
p Expression a
eEval
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
modSt forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e'
evalExpressionM (Flatten a
_ Expression a
e) = do
    Expression a
e' <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
    forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM ({-# SCC "mapChoice.setFrequency" #-} forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice forall a.
NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
setFrequency Expression a
e')
evalExpressionM (Annot a
_ Expression a
e DickinsonTy a
_) = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM Expression a
e
evalExpressionM (Random a
_ n :: Name a
n@(Name NonEmpty Text
_ (Unique Int
k) a
l)) = do
    IntMap (NonEmpty (Name a))
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors
    case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap (NonEmpty (Name a))
cs of
        Just NonEmpty (Name a)
ns -> forall a (m :: * -> *).
MonadState (EvalSt a) m =>
NonEmpty (Double, Expression a) -> m (Expression a)
pick (forall a. NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors NonEmpty (Name a)
ns)
        Maybe (NonEmpty (Name a))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. a -> Name a -> DickinsonError a
UnfoundType a
l Name a
n)

asConstructors :: NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors :: forall a. NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors NonEmpty (Name a)
ns = forall a. NonEmpty a -> NonEmpty (Double, a)
weight ((\Name a
n -> forall a. a -> Name a -> Expression a
Constructor (forall a. Name a -> a
loc Name a
n) Name a
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a)
ns)

mapChoice :: (NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)) -> Expression a -> Expression a
mapChoice :: forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (Choice a
l NonEmpty (Double, Expression a)
pes)     = forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f NonEmpty (Double, Expression a)
pes)
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
_ e :: Expression a
e@Literal{}        = Expression a
e
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
_ e :: Expression a
e@StrChunk{}       = Expression a
e
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (Interp a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Interp a
l (forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (MultiInterp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
MultiInterp a
l (forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (Concat a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Concat a
l (forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (Annot a
l Expression a
e DickinsonTy a
ty)     = forall a. a -> Expression a -> DickinsonTy a -> Expression a
Annot a
l (forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f Expression a
e) DickinsonTy a
ty
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f (Tuple a
l NonEmpty (Expression a)
es)       = forall a. a -> NonEmpty (Expression a) -> Expression a
Tuple a
l (forall a.
(NonEmpty (Double, Expression a)
 -> NonEmpty (Double, Expression a))
-> Expression a -> Expression a
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Expression a)
es)
mapChoice NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
_ Expression a
_                  = forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in function mapChoice."

mapText :: (T.Text -> T.Text) -> Expression a -> Expression a
mapText :: forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f (Literal a
l Text
t)      = forall a. a -> Text -> Expression a
Literal a
l (Text -> Text
f Text
t)
mapText Text -> Text
f (StrChunk a
l Text
t)     = forall a. a -> Text -> Expression a
StrChunk a
l (Text -> Text
f Text
t)
mapText Text -> Text
f (Choice a
l NonEmpty (Double, Expression a)
brs)     = let ps :: NonEmpty Double
ps = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
brs in forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Double
ps (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (Double, Expression a)
brs))
mapText Text -> Text
f (Interp a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Interp a
l (forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapText Text -> Text
f (MultiInterp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
MultiInterp a
l (forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapText Text -> Text
f (Annot a
l Expression a
e DickinsonTy a
ty)     = forall a. a -> Expression a -> DickinsonTy a -> Expression a
Annot a
l (forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f Expression a
e) DickinsonTy a
ty
mapText Text -> Text
f (Concat a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Concat a
l (forall a. (Text -> Text) -> Expression a -> Expression a
mapText Text -> Text
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expression a]
es)
mapText Text -> Text
_ Expression a
_                  = forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in function mapText."

setFrequency :: NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
setFrequency :: forall a.
NonEmpty (Double, Expression a) -> NonEmpty (Double, Expression a)
setFrequency = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Double
_, Expression a
e) -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ {-# SCC "countNodes" #-} forall a. Expression a -> Int
countNodes Expression a
e, Expression a
e))

countNodes :: Expression a -> Int
countNodes :: forall a. Expression a -> Int
countNodes Literal{}          = Int
1
countNodes StrChunk{}         = Int
1
countNodes (Choice a
_ NonEmpty (Double, Expression a)
pes)     = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Expression a -> Int
countNodes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (Double, Expression a)
pes)
countNodes (Interp a
_ [Expression a]
es)      = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Expression a -> Int
countNodes [Expression a]
es)
countNodes (MultiInterp a
_ [Expression a]
es) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Expression a -> Int
countNodes [Expression a]
es)
countNodes (Concat a
_ [Expression a]
es)      = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Expression a -> Int
countNodes [Expression a]
es)
countNodes (Annot a
_ Expression a
e DickinsonTy a
_)      = forall a. Expression a -> Int
countNodes Expression a
e
countNodes (Flatten a
_ Expression a
e)      = forall a. Expression a -> Int
countNodes Expression a
e
countNodes BuiltinFn{}        = Int
1
countNodes Constructor{}      = Int
1 -- TODO: lambdas too maybe? -> unclear
countNodes Expression a
_                  = forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in function countNodes"

concatOrFail :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => (T.Text -> T.Text) -> a -> [Expression a] -> m (Expression a)
concatOrFail :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
(Text -> Text) -> a -> [Expression a] -> m (Expression a)
concatOrFail Text -> Text
process a
l = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Text -> Expression a
Literal a
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
process forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m Text
evalExpressionAsTextM


evalExpressionAsTextM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m T.Text
evalExpressionAsTextM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m Text
evalExpressionAsTextM = forall (s :: * -> *) a (m :: * -> *).
(HasTyEnv s, MonadState (s a) m,
 MonadError (DickinsonError a) m) =>
Expression a -> m Text
extrText forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
evalExpressionM

resolveDeclarationM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Declaration a -> m (Declaration a)
resolveDeclarationM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Declaration a -> m (Declaration a)
resolveDeclarationM (Define a
l Name a
n Expression a
e) = forall a. a -> Name a -> Expression a -> Declaration a
Define a
l Name a
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveDeclarationM d :: Declaration a
d@TyDecl{}     = forall (f :: * -> *) a. Applicative f => a -> f a
pure Declaration a
d

-- | To aid the @:flatten@ function: resolve an expression, leaving
-- choices/branches intact.
resolveFlattenM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)
resolveFlattenM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM e :: Expression a
e@Literal{}     = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveFlattenM e :: Expression a
e@StrChunk{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveFlattenM e :: Expression a
e@Constructor{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveFlattenM e :: Expression a
e@BuiltinFn{}   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveFlattenM (Var a
_ Name a
n)       = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Name a -> m (Expression a)
lookupName Name a
n
resolveFlattenM (Choice a
l NonEmpty (Double, Expression a)
pes) = do
    let ps :: NonEmpty Double
ps = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
pes -- TODO: do these need to be renamed
    NonEmpty (Expression a)
es <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
pes)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Double
ps NonEmpty (Expression a)
es)
resolveFlattenM (Interp a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Interp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM [Expression a]
es
resolveFlattenM (MultiInterp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
MultiInterp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM [Expression a]
es
resolveFlattenM (Concat a
l [Expression a]
es)      = forall a. a -> [Expression a] -> Expression a
Concat a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM [Expression a]
es
resolveFlattenM (Tuple a
l NonEmpty (Expression a)
es)       = forall a. a -> NonEmpty (Expression a) -> Expression a
Tuple a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM NonEmpty (Expression a)
es
resolveFlattenM (Bind a
_ NonEmpty (Name a, Expression a)
bs Expression a
e)       = do
    let ns :: NonEmpty (Name a)
ns = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs
    NonEmpty (Expression a)
newBs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs)
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Name a)
ns NonEmpty (Expression a)
newBs)
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
resolveFlattenM (Let a
_ NonEmpty (Name a, Expression a)
bs Expression a
e)       = do
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) NonEmpty (Name a, Expression a)
bs
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
resolveFlattenM (Apply a
_ Expression a
e Expression a
e') = do
    Expression a
e'' <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
    case Expression a
e'' of
        Lambda a
_ Name a
n DickinsonTy a
_ Expression a
e''' ->
            forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt (forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e') forall a b. (a -> b) -> a -> b
$
                forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e'''
        BuiltinFn a
_ Builtin
b ->
            forall a. (Text -> Text) -> Expression a -> Expression a
mapText (Builtin -> Text -> Text
applyBuiltin Builtin
b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e'
        Expression a
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Ill-typed expression"
resolveFlattenM e :: Expression a
e@Lambda{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveFlattenM (Match a
l Expression a
e NonEmpty (Pattern a, Expression a)
brs) = do
    Expression a
eEval <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
    (Pattern a
p, Expression a
e') <- forall a (m :: * -> *).
MonadError (DickinsonError a) m =>
a
-> Expression a
-> [(Pattern a, Expression a)]
-> m (Pattern a, Expression a)
matchPattern a
l Expression a
eEval (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (Pattern a, Expression a)
brs)
    EvalSt a -> EvalSt a
modSt <- forall a (m :: * -> *).
(MonadError (DickinsonError a) m, MonadState (EvalSt a) m) =>
Pattern a -> Expression a -> m (EvalSt a -> EvalSt a)
bindPattern Pattern a
p Expression a
eEval
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
modSt forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e'
resolveFlattenM (Flatten a
l Expression a
e) =
    forall a. a -> Expression a -> Expression a
Flatten a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
resolveFlattenM (Annot a
_ Expression a
e DickinsonTy a
_) = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveFlattenM Expression a
e
resolveFlattenM (Random a
l n :: Name a
n@(Name NonEmpty Text
_ (Unique Int
k) a
l')) = do
    IntMap (NonEmpty (Name a))
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors
    case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap (NonEmpty (Name a))
cs of
        Just NonEmpty (Name a)
ns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (forall a. NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors NonEmpty (Name a)
ns)
        Maybe (NonEmpty (Name a))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. a -> Name a -> DickinsonError a
UnfoundType a
l' Name a
n)

-- | Resolve let bindings and such; do not perform choices or concatenations.
resolveExpressionM :: (MonadState (EvalSt a) m, MonadError (DickinsonError a) m) => Expression a -> m (Expression a)
resolveExpressionM :: forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM e :: Expression a
e@Literal{}     = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveExpressionM e :: Expression a
e@BuiltinFn{}   = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveExpressionM e :: Expression a
e@StrChunk{}    = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveExpressionM e :: Expression a
e@Constructor{} = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
e
resolveExpressionM v :: Expression a
v@(Var a
_ Name a
n)     = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression a
v) forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
MonadState (EvalSt a) m =>
Name a -> m (Maybe (Expression a))
tryLookupName Name a
n
resolveExpressionM (Choice a
l NonEmpty (Double, Expression a)
pes) = do
    let ps :: NonEmpty Double
ps = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
pes
    NonEmpty (Expression a)
es <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Double, Expression a)
pes)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty Double
ps NonEmpty (Expression a)
es)
resolveExpressionM (Interp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
Interp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM [Expression a]
es
resolveExpressionM (MultiInterp a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
MultiInterp a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM [Expression a]
es
resolveExpressionM (Concat a
l [Expression a]
es) = forall a. a -> [Expression a] -> Expression a
Concat a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM [Expression a]
es
resolveExpressionM (Tuple a
l NonEmpty (Expression a)
es) = forall a. a -> NonEmpty (Expression a) -> Expression a
Tuple a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM NonEmpty (Expression a)
es
resolveExpressionM (Bind a
_ NonEmpty (Name a, Expression a)
bs Expression a
e) = do
    let ns :: NonEmpty (Name a)
ns = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs
    NonEmpty (Expression a)
newBs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Name a, Expression a)
bs)
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Name a)
ns NonEmpty (Expression a)
newBs)
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveExpressionM (Let a
_ NonEmpty (Name a, Expression a)
bs Expression a
e) = do
    let stMod :: EvalSt a -> EvalSt a
stMod = forall (t :: * -> *) a. Foldable t => t (a -> a) -> a -> a
thread forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod) NonEmpty (Name a, Expression a)
bs
    forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt EvalSt a -> EvalSt a
stMod forall a b. (a -> b) -> a -> b
$
        forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveExpressionM (Apply a
l Expression a
e Expression a
e') = do
    Expression a
e'' <- forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
    case Expression a
e'' of
        Lambda a
_ Name a
n DickinsonTy a
_ Expression a
e''' ->
            forall s (m :: * -> *) b.
(HasRenames s, MonadState s m) =>
(s -> s) -> m b -> m b
withSt (forall a. Name a -> Expression a -> EvalSt a -> EvalSt a
nameMod Name a
n Expression a
e') forall a b. (a -> b) -> a -> b
$
                forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e'''
        Expression a
_ -> forall a. a -> Expression a -> Expression a -> Expression a
Apply a
l Expression a
e'' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e'
resolveExpressionM (Lambda a
l Name a
n DickinsonTy a
ty Expression a
e) = forall a.
a -> Name a -> DickinsonTy a -> Expression a -> Expression a
Lambda a
l Name a
n DickinsonTy a
ty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveExpressionM (Match a
l Expression a
e NonEmpty (Pattern a, Expression a)
brs) = do
    let ps :: NonEmpty (Pattern a)
ps = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Pattern a, Expression a)
brs
    NonEmpty (Expression a)
es <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) NonEmpty (Pattern a, Expression a)
brs
    forall a.
a
-> Expression a
-> NonEmpty (Pattern a, Expression a)
-> Expression a
Match a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty (Pattern a)
ps NonEmpty (Expression a)
es)
resolveExpressionM (Flatten a
l Expression a
e) =
    forall a. a -> Expression a -> Expression a
Flatten a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveExpressionM (Annot a
_ Expression a
e DickinsonTy a
_) = forall a (m :: * -> *).
(MonadState (EvalSt a) m, MonadError (DickinsonError a) m) =>
Expression a -> m (Expression a)
resolveExpressionM Expression a
e
resolveExpressionM (Random a
l n :: Name a
n@(Name NonEmpty Text
_ (Unique Int
k) a
l')) = do
    IntMap (NonEmpty (Name a))
cs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a. EvalSt a -> IntMap (NonEmpty (TyName a))
constructors
    case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap (NonEmpty (Name a))
cs of
        Just NonEmpty (Name a)
ns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> NonEmpty (Double, Expression a) -> Expression a
Choice a
l (forall a. NonEmpty (Name a) -> NonEmpty (Double, Expression a)
asConstructors NonEmpty (Name a)
ns)
        Maybe (NonEmpty (Name a))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. a -> Name a -> DickinsonError a
UnfoundType a
l' Name a
n)

applyBuiltin :: Builtin -> T.Text -> T.Text
applyBuiltin :: Builtin -> Text -> Text
applyBuiltin Builtin
AllCaps    = Text -> Text
T.toUpper
applyBuiltin Builtin
Capitalize = \Text
t -> case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Maybe (Char, Text)
Nothing      -> Text
""
    Just (Char
c, Text
t') -> Char -> Text -> Text
T.cons (Char -> Char
toUpper Char
c) Text
t'
applyBuiltin Builtin
Oulipo     = (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/= Char
'e')
applyBuiltin Builtin
Titlecase  = Text -> Text
T.toTitle -- TODO: better