--  --                                                          ; {{{1
--
--  File        : Koneko/Data.hs
--  Maintainer  : Felix C. Stegerman <flx@obfusk.net>
--  Date        : 2022-02-12
--
--  Copyright   : Copyright (C) 2022  Felix C. Stegerman
--  Version     : v0.0.1
--  License     : GPLv3+
--
--  --                                                          ; }}}1

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

                                                              --  {{{1
-- |
--
-- >>> :set -XOverloadedStrings
-- >>> import Data.Maybe
-- >>> id = fromJust . ident; q = KQuot . id
--
-- >>> nil
-- nil
-- >>> false
-- #f
-- >>> true
-- #t
-- >>> int 42
-- 42
-- >>> float (-1.23)
-- -1.23
-- >>> str "I like 猫s"
-- "I like 猫s"
-- >>> kwd "foo"
-- :foo
-- >>> pair (Kwd "answer") $ int 42
-- :answer 42 =>
-- >>> list [int 42, kwd "foo"]
-- ( 42 :foo )
-- >>> KIdent $ id "foo"
-- foo
-- >>> q "foo"
-- 'foo
-- >>> block [id "x", id "y"] [q "y", q "x"] Nothing
-- [ x y . 'y 'x ]
--
-- ... TODO ...
--

                                                              --  }}}1

module Koneko.Data (
  Identifier, Module, Evaluator, Args, KException(..), stackExpected,
  applyMissing, expected, unexpected, exceptionInfo, Kwd(..), Ident,
  unIdent, ident, Pair(..), List(..), Dict(..), Block(..),
  Builtin(..), Multi(..), RecordT(..), Record, recType, recValues,
  record, Thunk, runThunk, thunk, Scope(..), Context, ctxScope,
  KPrim(..), KValue(..), KType(..), Stack, freeVars, Cmp(..),
  escapeFrom, escapeTo, ToVal, toVal, FromVal, fromVal, toVals,
  fromVals, maybeToVal, eitherToVal, toJSON, fromJSON, emptyStack,
  push', push, rpush, rpush1, pop_, pop, pop2, pop3, pop4, pop_',
  pop', pop2', pop3', pop4', popN', pop1push, pop2push, pop1push1,
  pop2push1, primModule, bltnModule, prldModule, mainModule,
  initMainContext, initMain, initModule, forkContext, forkScope,
  defineIn, defineIn', importIn, importFromIn, lookup, lookupModule',
  moduleKeys, moduleNames, typeNames, typeOfPrim, typeOf, typeToKwd,
  typeToStr, typeAsStr, isNil, isBool, isInt, isFloat, isStr, isKwd,
  isPair, isList, isDict, isIdent, isQuot, isBlock, isBuiltin,
  isMulti, isRecordT, isRecord, isThunk, isCallable, isFunction, nil,
  false, true, bool, int, float, str, kwd, pair, list, dict, block,
  dictLookup, mkPrim, mkBltn, defPrim, defMulti, truthy, retOrThrow,
  recordTypeSig, underscored, digitParams, unKwds, recordToPairs
) where

import Control.DeepSeq (deepseq, NFData(..))
import Control.Exception (Exception, throw, throwIO)
import Control.Monad (liftM, when)
import Data.Bifunctor (bimap, second)
import Data.Char (intToDigit, isPrint, ord)
import Data.Data (Data, cast, gmapQ)
import Data.Foldable (traverse_)
import Data.Functor.Classes (liftCompare, liftCompare2)
import Data.List (intercalate, sort)
import Data.Maybe (catMaybes, isNothing)
import Data.String (IsString)
import Data.Text (Text)
import GHC.Generics (Generic)
import Numeric (showHex)
import Prelude hiding (lookup)
import System.IO.Unsafe (unsafeInterleaveIO)

#if !MIN_VERSION_GLASGOW_HASKELL(8, 8, 1, 0)
import Data.List (maximum)
import Data.Monoid ((<>))
#endif

import qualified Data.Aeson as AE
import qualified Data.HashMap.Strict as H
import qualified Data.HashSet as S
import qualified Data.HashTable.IO as HT
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LE
import qualified Data.Vector as V
import qualified Prelude as P

import qualified Koneko.Misc as M

-- types --

type HashTable k v      = HT.BasicHashTable k v
type ModuleLookupTable  = HashTable Identifier KValue
type ScopeLookupTable   = H.HashMap Identifier KValue
type DictTable          = H.HashMap Identifier KValue
type MultiTable         = HashTable [Identifier] Block

type Identifier         = Text
type Module             = ModuleLookupTable
type Evaluator          = Context -> Stack -> IO Stack
type Args               = [(Identifier, KValue)]

-- TODO
data KException
    = ParseError !String
    | EvalUnexpected !String  -- ^ unexpected value during eval
    | EvalScopelessBlock      -- ^ block w/o scope during eval
    | ModuleNameError !String
    | ModuleLoadError !String
    | NameError !String       -- ^ ident lookup failed
    | StackUnderflow          -- ^ stack was empty
    | Expected !EExpected
    | MultiMatchFailed !String !String
    | UncomparableType !String
    | UncomparableTypes !String !String
    | UncallableType !String
    | UnapplicableType !String !String
    | UnknownField !String !String
    | EmptyList !String
    | IndexError !String !String
    | KeyError !String !String
    | RangeError !String
    | DivideByZero
    | InvalidRx !String
    | Fail !String
    | NotImplemented !String
  deriving Typeable KException
DataType
Constr
Typeable KException
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> KException -> c KException)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c KException)
-> (KException -> Constr)
-> (KException -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c KException))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c KException))
-> ((forall b. Data b => b -> b) -> KException -> KException)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> KException -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> KException -> r)
-> (forall u. (forall d. Data d => d -> u) -> KException -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> KException -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> KException -> m KException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> KException -> m KException)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> KException -> m KException)
-> Data KException
KException -> DataType
KException -> Constr
(forall b. Data b => b -> b) -> KException -> KException
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KException -> c KException
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KException
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> KException -> u
forall u. (forall d. Data d => d -> u) -> KException -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> KException -> m KException
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KException -> m KException
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KException
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KException -> c KException
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c KException)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c KException)
$cNotImplemented :: Constr
$cFail :: Constr
$cInvalidRx :: Constr
$cDivideByZero :: Constr
$cRangeError :: Constr
$cKeyError :: Constr
$cIndexError :: Constr
$cEmptyList :: Constr
$cUnknownField :: Constr
$cUnapplicableType :: Constr
$cUncallableType :: Constr
$cUncomparableTypes :: Constr
$cUncomparableType :: Constr
$cMultiMatchFailed :: Constr
$cExpected :: Constr
$cStackUnderflow :: Constr
$cNameError :: Constr
$cModuleLoadError :: Constr
$cModuleNameError :: Constr
$cEvalScopelessBlock :: Constr
$cEvalUnexpected :: Constr
$cParseError :: Constr
$tKException :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> KException -> m KException
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KException -> m KException
gmapMp :: (forall d. Data d => d -> m d) -> KException -> m KException
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> KException -> m KException
gmapM :: (forall d. Data d => d -> m d) -> KException -> m KException
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> KException -> m KException
gmapQi :: Int -> (forall d. Data d => d -> u) -> KException -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> KException -> u
gmapQ :: (forall d. Data d => d -> u) -> KException -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> KException -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> KException -> r
gmapT :: (forall b. Data b => b -> b) -> KException -> KException
$cgmapT :: (forall b. Data b => b -> b) -> KException -> KException
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c KException)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c KException)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c KException)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c KException)
dataTypeOf :: KException -> DataType
$cdataTypeOf :: KException -> DataType
toConstr :: KException -> Constr
$ctoConstr :: KException -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KException
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c KException
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KException -> c KException
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> KException -> c KException
$cp1Data :: Typeable KException
Data

instance Exception KException

data EExpected
    = StackExpected !String !String
    | ApplyMissing !Bool
    | OtherExpected !String
  deriving Typeable EExpected
DataType
Constr
Typeable EExpected
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> EExpected -> c EExpected)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c EExpected)
-> (EExpected -> Constr)
-> (EExpected -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c EExpected))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c EExpected))
-> ((forall b. Data b => b -> b) -> EExpected -> EExpected)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> EExpected -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> EExpected -> r)
-> (forall u. (forall d. Data d => d -> u) -> EExpected -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> EExpected -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> EExpected -> m EExpected)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> EExpected -> m EExpected)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> EExpected -> m EExpected)
-> Data EExpected
EExpected -> DataType
EExpected -> Constr
(forall b. Data b => b -> b) -> EExpected -> EExpected
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EExpected -> c EExpected
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c EExpected
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> EExpected -> u
forall u. (forall d. Data d => d -> u) -> EExpected -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> EExpected -> m EExpected
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> EExpected -> m EExpected
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c EExpected
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EExpected -> c EExpected
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c EExpected)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c EExpected)
$cOtherExpected :: Constr
$cApplyMissing :: Constr
$cStackExpected :: Constr
$tEExpected :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> EExpected -> m EExpected
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> EExpected -> m EExpected
gmapMp :: (forall d. Data d => d -> m d) -> EExpected -> m EExpected
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> EExpected -> m EExpected
gmapM :: (forall d. Data d => d -> m d) -> EExpected -> m EExpected
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> EExpected -> m EExpected
gmapQi :: Int -> (forall d. Data d => d -> u) -> EExpected -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> EExpected -> u
gmapQ :: (forall d. Data d => d -> u) -> EExpected -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> EExpected -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> EExpected -> r
gmapT :: (forall b. Data b => b -> b) -> EExpected -> EExpected
$cgmapT :: (forall b. Data b => b -> b) -> EExpected -> EExpected
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c EExpected)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c EExpected)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c EExpected)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c EExpected)
dataTypeOf :: EExpected -> DataType
$cdataTypeOf :: EExpected -> DataType
toConstr :: EExpected -> Constr
$ctoConstr :: EExpected -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c EExpected
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c EExpected
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EExpected -> c EExpected
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> EExpected -> c EExpected
$cp1Data :: Typeable EExpected
Data

stackExpected :: Either String KValue -> String -> KException
stackExpected :: Either String KValue -> String -> KException
stackExpected Either String KValue
x = EExpected -> KException
Expected (EExpected -> KException)
-> (String -> EExpected) -> String -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> EExpected
StackExpected ((String -> String)
-> (KValue -> String) -> Either String KValue -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> String
forall a. a -> a
id KValue -> String
forall a. IsString a => KValue -> a
typeAsStr Either String KValue
x)

applyMissing :: Bool -> KException
applyMissing :: Bool -> KException
applyMissing = EExpected -> KException
Expected (EExpected -> KException)
-> (Bool -> EExpected) -> Bool -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> EExpected
ApplyMissing

expected, unexpected :: String -> KException
expected :: String -> KException
expected   = EExpected -> KException
Expected (EExpected -> KException)
-> (String -> EExpected) -> String -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EExpected
OtherExpected (String -> EExpected) -> (String -> String) -> String -> EExpected
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++)
unexpected :: String -> KException
unexpected = EExpected -> KException
Expected (EExpected -> KException)
-> (String -> EExpected) -> String -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EExpected
OtherExpected (String -> EExpected) -> (String -> String) -> String -> EExpected
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++)

exceptionInfo :: KException -> [String]
exceptionInfo :: KException -> [String]
exceptionInfo (Expected EExpected
x) = [EExpected -> String
forall a. Show a => a -> String
show EExpected
x]
exceptionInfo KException
x = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => d -> [String]) -> KException -> [[String]]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ([String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (Maybe String -> [String]) -> (d -> Maybe String) -> d -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Maybe String
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast) KException
x

-- TODO: intern?!
newtype Kwd = Kwd { Kwd -> Identifier
unKwd :: Identifier }
  deriving (Kwd -> Kwd -> Bool
(Kwd -> Kwd -> Bool) -> (Kwd -> Kwd -> Bool) -> Eq Kwd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Kwd -> Kwd -> Bool
$c/= :: Kwd -> Kwd -> Bool
== :: Kwd -> Kwd -> Bool
$c== :: Kwd -> Kwd -> Bool
Eq, Eq Kwd
Eq Kwd
-> (Kwd -> Kwd -> Ordering)
-> (Kwd -> Kwd -> Bool)
-> (Kwd -> Kwd -> Bool)
-> (Kwd -> Kwd -> Bool)
-> (Kwd -> Kwd -> Bool)
-> (Kwd -> Kwd -> Kwd)
-> (Kwd -> Kwd -> Kwd)
-> Ord Kwd
Kwd -> Kwd -> Bool
Kwd -> Kwd -> Ordering
Kwd -> Kwd -> Kwd
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Kwd -> Kwd -> Kwd
$cmin :: Kwd -> Kwd -> Kwd
max :: Kwd -> Kwd -> Kwd
$cmax :: Kwd -> Kwd -> Kwd
>= :: Kwd -> Kwd -> Bool
$c>= :: Kwd -> Kwd -> Bool
> :: Kwd -> Kwd -> Bool
$c> :: Kwd -> Kwd -> Bool
<= :: Kwd -> Kwd -> Bool
$c<= :: Kwd -> Kwd -> Bool
< :: Kwd -> Kwd -> Bool
$c< :: Kwd -> Kwd -> Bool
compare :: Kwd -> Kwd -> Ordering
$ccompare :: Kwd -> Kwd -> Ordering
$cp1Ord :: Eq Kwd
Ord, (forall x. Kwd -> Rep Kwd x)
-> (forall x. Rep Kwd x -> Kwd) -> Generic Kwd
forall x. Rep Kwd x -> Kwd
forall x. Kwd -> Rep Kwd x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Kwd x -> Kwd
$cfrom :: forall x. Kwd -> Rep Kwd x
Generic, Kwd -> ()
(Kwd -> ()) -> NFData Kwd
forall a. (a -> ()) -> NFData a
rnf :: Kwd -> ()
$crnf :: Kwd -> ()
NFData)

newtype Ident = Ident_ { Ident -> Identifier
unIdent :: Identifier }
  deriving (Ident -> Ident -> Bool
(Ident -> Ident -> Bool) -> (Ident -> Ident -> Bool) -> Eq Ident
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ident -> Ident -> Bool
$c/= :: Ident -> Ident -> Bool
== :: Ident -> Ident -> Bool
$c== :: Ident -> Ident -> Bool
Eq, Eq Ident
Eq Ident
-> (Ident -> Ident -> Ordering)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Bool)
-> (Ident -> Ident -> Ident)
-> (Ident -> Ident -> Ident)
-> Ord Ident
Ident -> Ident -> Bool
Ident -> Ident -> Ordering
Ident -> Ident -> Ident
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Ident -> Ident -> Ident
$cmin :: Ident -> Ident -> Ident
max :: Ident -> Ident -> Ident
$cmax :: Ident -> Ident -> Ident
>= :: Ident -> Ident -> Bool
$c>= :: Ident -> Ident -> Bool
> :: Ident -> Ident -> Bool
$c> :: Ident -> Ident -> Bool
<= :: Ident -> Ident -> Bool
$c<= :: Ident -> Ident -> Bool
< :: Ident -> Ident -> Bool
$c< :: Ident -> Ident -> Bool
compare :: Ident -> Ident -> Ordering
$ccompare :: Ident -> Ident -> Ordering
$cp1Ord :: Eq Ident
Ord, (forall x. Ident -> Rep Ident x)
-> (forall x. Rep Ident x -> Ident) -> Generic Ident
forall x. Rep Ident x -> Ident
forall x. Ident -> Rep Ident x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ident x -> Ident
$cfrom :: forall x. Ident -> Rep Ident x
Generic, Ident -> ()
(Ident -> ()) -> NFData Ident
forall a. (a -> ()) -> NFData a
rnf :: Ident -> ()
$crnf :: Ident -> ()
NFData)

ident :: Identifier -> Maybe Ident
ident :: Identifier -> Maybe Ident
ident Identifier
s = if Identifier -> Bool
M.isIdent Identifier
s then Ident -> Maybe Ident
forall a. a -> Maybe a
Just (Ident -> Maybe Ident) -> Ident -> Maybe Ident
forall a b. (a -> b) -> a -> b
$ Identifier -> Ident
Ident_ Identifier
s else Maybe Ident
forall a. Maybe a
Nothing

data Pair = Pair { Pair -> Kwd
key :: Kwd, Pair -> KValue
value :: KValue }
  deriving (Pair -> Pair -> Bool
(Pair -> Pair -> Bool) -> (Pair -> Pair -> Bool) -> Eq Pair
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pair -> Pair -> Bool
$c/= :: Pair -> Pair -> Bool
== :: Pair -> Pair -> Bool
$c== :: Pair -> Pair -> Bool
Eq, Eq Pair
Eq Pair
-> (Pair -> Pair -> Ordering)
-> (Pair -> Pair -> Bool)
-> (Pair -> Pair -> Bool)
-> (Pair -> Pair -> Bool)
-> (Pair -> Pair -> Bool)
-> (Pair -> Pair -> Pair)
-> (Pair -> Pair -> Pair)
-> Ord Pair
Pair -> Pair -> Bool
Pair -> Pair -> Ordering
Pair -> Pair -> Pair
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pair -> Pair -> Pair
$cmin :: Pair -> Pair -> Pair
max :: Pair -> Pair -> Pair
$cmax :: Pair -> Pair -> Pair
>= :: Pair -> Pair -> Bool
$c>= :: Pair -> Pair -> Bool
> :: Pair -> Pair -> Bool
$c> :: Pair -> Pair -> Bool
<= :: Pair -> Pair -> Bool
$c<= :: Pair -> Pair -> Bool
< :: Pair -> Pair -> Bool
$c< :: Pair -> Pair -> Bool
compare :: Pair -> Pair -> Ordering
$ccompare :: Pair -> Pair -> Ordering
$cp1Ord :: Eq Pair
Ord, (forall x. Pair -> Rep Pair x)
-> (forall x. Rep Pair x -> Pair) -> Generic Pair
forall x. Rep Pair x -> Pair
forall x. Pair -> Rep Pair x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Pair x -> Pair
$cfrom :: forall x. Pair -> Rep Pair x
Generic, Pair -> ()
(Pair -> ()) -> NFData Pair
forall a. (a -> ()) -> NFData a
rnf :: Pair -> ()
$crnf :: Pair -> ()
NFData)

newtype List = List { List -> [KValue]
unList :: [KValue] }
  deriving (List -> List -> Bool
(List -> List -> Bool) -> (List -> List -> Bool) -> Eq List
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: List -> List -> Bool
$c/= :: List -> List -> Bool
== :: List -> List -> Bool
$c== :: List -> List -> Bool
Eq, Eq List
Eq List
-> (List -> List -> Ordering)
-> (List -> List -> Bool)
-> (List -> List -> Bool)
-> (List -> List -> Bool)
-> (List -> List -> Bool)
-> (List -> List -> List)
-> (List -> List -> List)
-> Ord List
List -> List -> Bool
List -> List -> Ordering
List -> List -> List
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: List -> List -> List
$cmin :: List -> List -> List
max :: List -> List -> List
$cmax :: List -> List -> List
>= :: List -> List -> Bool
$c>= :: List -> List -> Bool
> :: List -> List -> Bool
$c> :: List -> List -> Bool
<= :: List -> List -> Bool
$c<= :: List -> List -> Bool
< :: List -> List -> Bool
$c< :: List -> List -> Bool
compare :: List -> List -> Ordering
$ccompare :: List -> List -> Ordering
$cp1Ord :: Eq List
Ord, (forall x. List -> Rep List x)
-> (forall x. Rep List x -> List) -> Generic List
forall x. Rep List x -> List
forall x. List -> Rep List x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep List x -> List
$cfrom :: forall x. List -> Rep List x
Generic, List -> ()
(List -> ()) -> NFData List
forall a. (a -> ()) -> NFData a
rnf :: List -> ()
$crnf :: List -> ()
NFData)

newtype Dict = Dict { Dict -> DictTable
unDict :: DictTable }
  deriving (Dict -> Dict -> Bool
(Dict -> Dict -> Bool) -> (Dict -> Dict -> Bool) -> Eq Dict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dict -> Dict -> Bool
$c/= :: Dict -> Dict -> Bool
== :: Dict -> Dict -> Bool
$c== :: Dict -> Dict -> Bool
Eq, Eq Dict
Eq Dict
-> (Dict -> Dict -> Ordering)
-> (Dict -> Dict -> Bool)
-> (Dict -> Dict -> Bool)
-> (Dict -> Dict -> Bool)
-> (Dict -> Dict -> Bool)
-> (Dict -> Dict -> Dict)
-> (Dict -> Dict -> Dict)
-> Ord Dict
Dict -> Dict -> Bool
Dict -> Dict -> Ordering
Dict -> Dict -> Dict
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Dict -> Dict -> Dict
$cmin :: Dict -> Dict -> Dict
max :: Dict -> Dict -> Dict
$cmax :: Dict -> Dict -> Dict
>= :: Dict -> Dict -> Bool
$c>= :: Dict -> Dict -> Bool
> :: Dict -> Dict -> Bool
$c> :: Dict -> Dict -> Bool
<= :: Dict -> Dict -> Bool
$c<= :: Dict -> Dict -> Bool
< :: Dict -> Dict -> Bool
$c< :: Dict -> Dict -> Bool
compare :: Dict -> Dict -> Ordering
$ccompare :: Dict -> Dict -> Ordering
$cp1Ord :: Eq Dict
Ord, (forall x. Dict -> Rep Dict x)
-> (forall x. Rep Dict x -> Dict) -> Generic Dict
forall x. Rep Dict x -> Dict
forall x. Dict -> Rep Dict x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Dict x -> Dict
$cfrom :: forall x. Dict -> Rep Dict x
Generic, Dict -> ()
(Dict -> ()) -> NFData Dict
forall a. (a -> ()) -> NFData a
rnf :: Dict -> ()
$crnf :: Dict -> ()
NFData)

data Block = Block {
  Block -> [Ident]
blkParams :: [Ident],
  Block -> [KValue]
blkCode   :: [KValue],
  Block -> Maybe Scope
blkScope  :: Maybe Scope
} deriving ((forall x. Block -> Rep Block x)
-> (forall x. Rep Block x -> Block) -> Generic Block
forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generic, Block -> ()
(Block -> ()) -> NFData Block
forall a. (a -> ()) -> NFData a
rnf :: Block -> ()
$crnf :: Block -> ()
NFData)

data Builtin = Builtin {
  Builtin -> Bool
biPrim  :: Bool,
  Builtin -> Identifier
biName  :: Identifier,
  Builtin -> Evaluator
biRun   :: Evaluator
}

-- TODO
instance NFData Builtin where
  rnf :: Builtin -> ()
rnf Builtin{Bool
Identifier
Evaluator
biRun :: Evaluator
biName :: Identifier
biPrim :: Bool
biRun :: Builtin -> Evaluator
biName :: Builtin -> Identifier
biPrim :: Builtin -> Bool
..} = (Bool
biPrim, Identifier
biName) (Bool, Identifier) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

data Multi = Multi {
  Multi -> Int
mltArity  :: Int,
  Multi -> Identifier
mltName   :: Identifier,
  Multi -> MultiTable
mltTable  :: MultiTable
}

-- TODO
instance NFData Multi where
  rnf :: Multi -> ()
rnf Multi{Int
Identifier
MultiTable
mltTable :: MultiTable
mltName :: Identifier
mltArity :: Int
mltTable :: Multi -> MultiTable
mltName :: Multi -> Identifier
mltArity :: Multi -> Int
..} = (Int
mltArity, Identifier
mltName) (Int, Identifier) -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

data RecordT = RecordT {
  RecordT -> Identifier
recName   :: Identifier,
  RecordT -> [Identifier]
recFields :: [Identifier]
} deriving (RecordT -> RecordT -> Bool
(RecordT -> RecordT -> Bool)
-> (RecordT -> RecordT -> Bool) -> Eq RecordT
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RecordT -> RecordT -> Bool
$c/= :: RecordT -> RecordT -> Bool
== :: RecordT -> RecordT -> Bool
$c== :: RecordT -> RecordT -> Bool
Eq, Eq RecordT
Eq RecordT
-> (RecordT -> RecordT -> Ordering)
-> (RecordT -> RecordT -> Bool)
-> (RecordT -> RecordT -> Bool)
-> (RecordT -> RecordT -> Bool)
-> (RecordT -> RecordT -> Bool)
-> (RecordT -> RecordT -> RecordT)
-> (RecordT -> RecordT -> RecordT)
-> Ord RecordT
RecordT -> RecordT -> Bool
RecordT -> RecordT -> Ordering
RecordT -> RecordT -> RecordT
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RecordT -> RecordT -> RecordT
$cmin :: RecordT -> RecordT -> RecordT
max :: RecordT -> RecordT -> RecordT
$cmax :: RecordT -> RecordT -> RecordT
>= :: RecordT -> RecordT -> Bool
$c>= :: RecordT -> RecordT -> Bool
> :: RecordT -> RecordT -> Bool
$c> :: RecordT -> RecordT -> Bool
<= :: RecordT -> RecordT -> Bool
$c<= :: RecordT -> RecordT -> Bool
< :: RecordT -> RecordT -> Bool
$c< :: RecordT -> RecordT -> Bool
compare :: RecordT -> RecordT -> Ordering
$ccompare :: RecordT -> RecordT -> Ordering
$cp1Ord :: Eq RecordT
Ord, (forall x. RecordT -> Rep RecordT x)
-> (forall x. Rep RecordT x -> RecordT) -> Generic RecordT
forall x. Rep RecordT x -> RecordT
forall x. RecordT -> Rep RecordT x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RecordT x -> RecordT
$cfrom :: forall x. RecordT -> Rep RecordT x
Generic, RecordT -> ()
(RecordT -> ()) -> NFData RecordT
forall a. (a -> ()) -> NFData a
rnf :: RecordT -> ()
$crnf :: RecordT -> ()
NFData)

data Record = Record {
  Record -> RecordT
recType   :: RecordT,
  Record -> [KValue]
recValues :: [KValue]
} deriving (Record -> Record -> Bool
(Record -> Record -> Bool)
-> (Record -> Record -> Bool) -> Eq Record
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Record -> Record -> Bool
$c/= :: Record -> Record -> Bool
== :: Record -> Record -> Bool
$c== :: Record -> Record -> Bool
Eq, Eq Record
Eq Record
-> (Record -> Record -> Ordering)
-> (Record -> Record -> Bool)
-> (Record -> Record -> Bool)
-> (Record -> Record -> Bool)
-> (Record -> Record -> Bool)
-> (Record -> Record -> Record)
-> (Record -> Record -> Record)
-> Ord Record
Record -> Record -> Bool
Record -> Record -> Ordering
Record -> Record -> Record
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Record -> Record -> Record
$cmin :: Record -> Record -> Record
max :: Record -> Record -> Record
$cmax :: Record -> Record -> Record
>= :: Record -> Record -> Bool
$c>= :: Record -> Record -> Bool
> :: Record -> Record -> Bool
$c> :: Record -> Record -> Bool
<= :: Record -> Record -> Bool
$c<= :: Record -> Record -> Bool
< :: Record -> Record -> Bool
$c< :: Record -> Record -> Bool
compare :: Record -> Record -> Ordering
$ccompare :: Record -> Record -> Ordering
$cp1Ord :: Eq Record
Ord, (forall x. Record -> Rep Record x)
-> (forall x. Rep Record x -> Record) -> Generic Record
forall x. Rep Record x -> Record
forall x. Record -> Rep Record x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Record x -> Record
$cfrom :: forall x. Record -> Rep Record x
Generic, Record -> ()
(Record -> ()) -> NFData Record
forall a. (a -> ()) -> NFData a
rnf :: Record -> ()
$crnf :: Record -> ()
NFData)

record :: RecordT -> [KValue] -> Either KException Record
record :: RecordT -> [KValue] -> Either KException Record
record recType :: RecordT
recType@RecordT{[Identifier]
Identifier
recFields :: [Identifier]
recName :: Identifier
recFields :: RecordT -> [Identifier]
recName :: RecordT -> Identifier
..} [KValue]
recValues
  | [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
recFields Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [KValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [KValue]
recValues = Record -> Either KException Record
forall a b. b -> Either a b
Right Record :: RecordT -> [KValue] -> Record
Record{[KValue]
RecordT
recValues :: [KValue]
recType :: RecordT
recValues :: [KValue]
recType :: RecordT
..}
  | Bool
otherwise = KException -> Either KException Record
forall a b. a -> Either a b
Left (KException -> Either KException Record)
-> KException -> Either KException Record
forall a b. (a -> b) -> a -> b
$ String -> KException
expected (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
recFields) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
" arg(s) for record " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
T.unpack Identifier
recName

data Thunk = Thunk { Thunk -> IO KValue
runThunk :: IO KValue }

thunk :: IO KValue -> IO Thunk
thunk :: IO KValue -> IO Thunk
thunk IO KValue
x = Thunk -> IO Thunk
forall (m :: * -> *) a. Monad m => a -> m a
return (Thunk -> IO Thunk)
-> (IO KValue -> Thunk) -> IO KValue -> IO Thunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO KValue -> Thunk
Thunk (IO KValue -> IO Thunk) -> IO (IO KValue) -> IO Thunk
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO KValue -> IO (IO KValue)
forall a. IO a -> IO (IO a)
_once IO KValue
x

_once :: IO a -> IO (IO a)
_once :: IO a -> IO (IO a)
_once = (a -> IO a) -> IO a -> IO (IO a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a -> IO (IO a)) -> (IO a -> IO a) -> IO a -> IO (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO

-- TODO
instance NFData Thunk where
  rnf :: Thunk -> ()
rnf Thunk
_ = ()

data Scope = Scope {
  Scope -> Identifier
modName :: Identifier,
  Scope -> DictTable
table   :: ScopeLookupTable
}

-- TODO
instance NFData Scope where
  rnf :: Scope -> ()
rnf Scope{Identifier
DictTable
table :: DictTable
modName :: Identifier
table :: Scope -> DictTable
modName :: Scope -> Identifier
..} = Identifier
modName Identifier -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

data Context = Context {
  Context -> HashTable Identifier Module
modules   :: HashTable Identifier Module,
  Context -> HashTable Identifier [Identifier]
imports   :: HashTable Identifier [Identifier],
  Context -> Scope
ctxScope  :: Scope
}

-- TODO: + Rx
data KPrim
    = KNil | KBool Bool | KInt Integer | KFloat Double
    | KStr Text | KKwd Kwd
  deriving (KPrim -> KPrim -> Bool
(KPrim -> KPrim -> Bool) -> (KPrim -> KPrim -> Bool) -> Eq KPrim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KPrim -> KPrim -> Bool
$c/= :: KPrim -> KPrim -> Bool
== :: KPrim -> KPrim -> Bool
$c== :: KPrim -> KPrim -> Bool
Eq, Eq KPrim
Eq KPrim
-> (KPrim -> KPrim -> Ordering)
-> (KPrim -> KPrim -> Bool)
-> (KPrim -> KPrim -> Bool)
-> (KPrim -> KPrim -> Bool)
-> (KPrim -> KPrim -> Bool)
-> (KPrim -> KPrim -> KPrim)
-> (KPrim -> KPrim -> KPrim)
-> Ord KPrim
KPrim -> KPrim -> Bool
KPrim -> KPrim -> Ordering
KPrim -> KPrim -> KPrim
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KPrim -> KPrim -> KPrim
$cmin :: KPrim -> KPrim -> KPrim
max :: KPrim -> KPrim -> KPrim
$cmax :: KPrim -> KPrim -> KPrim
>= :: KPrim -> KPrim -> Bool
$c>= :: KPrim -> KPrim -> Bool
> :: KPrim -> KPrim -> Bool
$c> :: KPrim -> KPrim -> Bool
<= :: KPrim -> KPrim -> Bool
$c<= :: KPrim -> KPrim -> Bool
< :: KPrim -> KPrim -> Bool
$c< :: KPrim -> KPrim -> Bool
compare :: KPrim -> KPrim -> Ordering
$ccompare :: KPrim -> KPrim -> Ordering
$cp1Ord :: Eq KPrim
Ord, (forall x. KPrim -> Rep KPrim x)
-> (forall x. Rep KPrim x -> KPrim) -> Generic KPrim
forall x. Rep KPrim x -> KPrim
forall x. KPrim -> Rep KPrim x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep KPrim x -> KPrim
$cfrom :: forall x. KPrim -> Rep KPrim x
Generic, KPrim -> ()
(KPrim -> ()) -> NFData KPrim
forall a. (a -> ()) -> NFData a
rnf :: KPrim -> ()
$crnf :: KPrim -> ()
NFData)

-- TODO
data KValue
    = KPrim KPrim | KPair Pair | KList List | KDict Dict
    | KIdent Ident | KQuot Ident | KBlock Block | KBuiltin Builtin
    | KMulti Multi | KRecordT RecordT | KRecord Record | KThunk Thunk
  deriving (KValue -> KValue -> Bool
(KValue -> KValue -> Bool)
-> (KValue -> KValue -> Bool) -> Eq KValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KValue -> KValue -> Bool
$c/= :: KValue -> KValue -> Bool
== :: KValue -> KValue -> Bool
$c== :: KValue -> KValue -> Bool
Eq, Eq KValue
Eq KValue
-> (KValue -> KValue -> Ordering)
-> (KValue -> KValue -> Bool)
-> (KValue -> KValue -> Bool)
-> (KValue -> KValue -> Bool)
-> (KValue -> KValue -> Bool)
-> (KValue -> KValue -> KValue)
-> (KValue -> KValue -> KValue)
-> Ord KValue
KValue -> KValue -> Bool
KValue -> KValue -> Ordering
KValue -> KValue -> KValue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KValue -> KValue -> KValue
$cmin :: KValue -> KValue -> KValue
max :: KValue -> KValue -> KValue
$cmax :: KValue -> KValue -> KValue
>= :: KValue -> KValue -> Bool
$c>= :: KValue -> KValue -> Bool
> :: KValue -> KValue -> Bool
$c> :: KValue -> KValue -> Bool
<= :: KValue -> KValue -> Bool
$c<= :: KValue -> KValue -> Bool
< :: KValue -> KValue -> Bool
$c< :: KValue -> KValue -> Bool
compare :: KValue -> KValue -> Ordering
$ccompare :: KValue -> KValue -> Ordering
$cp1Ord :: Eq KValue
Ord, (forall x. KValue -> Rep KValue x)
-> (forall x. Rep KValue x -> KValue) -> Generic KValue
forall x. Rep KValue x -> KValue
forall x. KValue -> Rep KValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep KValue x -> KValue
$cfrom :: forall x. KValue -> Rep KValue x
Generic, KValue -> ()
(KValue -> ()) -> NFData KValue
forall a. (a -> ()) -> NFData a
rnf :: KValue -> ()
$crnf :: KValue -> ()
NFData)

data KType
    = TNil | TBool | TInt | TFloat | TStr | TKwd | TPair | TList
    | TDict | TIdent | TQuot | TBlock | TBuiltin | TMulti | TRecordT
    | TRecord | TThunk
  deriving (KType -> KType -> Bool
(KType -> KType -> Bool) -> (KType -> KType -> Bool) -> Eq KType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KType -> KType -> Bool
$c/= :: KType -> KType -> Bool
== :: KType -> KType -> Bool
$c== :: KType -> KType -> Bool
Eq, Eq KType
Eq KType
-> (KType -> KType -> Ordering)
-> (KType -> KType -> Bool)
-> (KType -> KType -> Bool)
-> (KType -> KType -> Bool)
-> (KType -> KType -> Bool)
-> (KType -> KType -> KType)
-> (KType -> KType -> KType)
-> Ord KType
KType -> KType -> Bool
KType -> KType -> Ordering
KType -> KType -> KType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: KType -> KType -> KType
$cmin :: KType -> KType -> KType
max :: KType -> KType -> KType
$cmax :: KType -> KType -> KType
>= :: KType -> KType -> Bool
$c>= :: KType -> KType -> Bool
> :: KType -> KType -> Bool
$c> :: KType -> KType -> Bool
<= :: KType -> KType -> Bool
$c<= :: KType -> KType -> Bool
< :: KType -> KType -> Bool
$c< :: KType -> KType -> Bool
compare :: KType -> KType -> Ordering
$ccompare :: KType -> KType -> Ordering
$cp1Ord :: Eq KType
Ord, (forall x. KType -> Rep KType x)
-> (forall x. Rep KType x -> KType) -> Generic KType
forall x. Rep KType x -> KType
forall x. KType -> Rep KType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep KType x -> KType
$cfrom :: forall x. KType -> Rep KType x
Generic, KType -> ()
(KType -> ()) -> NFData KType
forall a. (a -> ()) -> NFData a
rnf :: KType -> ()
$crnf :: KType -> ()
NFData)

type Stack = [KValue]

-- TODO
freeVars :: [KValue] -> S.HashSet Identifier
freeVars :: [KValue] -> HashSet Identifier
freeVars = HashSet Identifier -> [KValue] -> HashSet Identifier
umap HashSet Identifier
forall a. HashSet a
S.empty
  where
    f :: HashSet Identifier -> KValue -> HashSet Identifier
f HashSet Identifier
s (KList List
l)   = HashSet Identifier -> [KValue] -> HashSet Identifier
umap HashSet Identifier
s ([KValue] -> HashSet Identifier) -> [KValue] -> HashSet Identifier
forall a b. (a -> b) -> a -> b
$ List -> [KValue]
unList List
l
    f HashSet Identifier
s (KIdent Ident
i)  = HashSet Identifier -> Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => HashSet a -> a -> HashSet a
g HashSet Identifier
s (Identifier -> HashSet Identifier)
-> Identifier -> HashSet Identifier
forall a b. (a -> b) -> a -> b
$ Ident -> Identifier
unIdent Ident
i
    f HashSet Identifier
s (KQuot Ident
i)   = HashSet Identifier -> Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => HashSet a -> a -> HashSet a
g HashSet Identifier
s (Identifier -> HashSet Identifier)
-> Identifier -> HashSet Identifier
forall a b. (a -> b) -> a -> b
$ Ident -> Identifier
unIdent Ident
i
    f HashSet Identifier
s (KBlock Block
b)  = let p :: HashSet Identifier
p = [Identifier] -> HashSet Identifier
forall a. (Eq a, Hashable a) => [a] -> HashSet a
S.fromList ([Identifier] -> HashSet Identifier)
-> [Identifier] -> HashSet Identifier
forall a b. (a -> b) -> a -> b
$ (Ident -> Identifier) -> [Ident] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Identifier
unIdent ([Ident] -> [Identifier]) -> [Ident] -> [Identifier]
forall a b. (a -> b) -> a -> b
$ Block -> [Ident]
blkParams Block
b
                      in HashSet Identifier -> [KValue] -> HashSet Identifier
umap (HashSet Identifier -> HashSet Identifier -> HashSet Identifier
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
S.union HashSet Identifier
p HashSet Identifier
s) ([KValue] -> HashSet Identifier) -> [KValue] -> HashSet Identifier
forall a b. (a -> b) -> a -> b
$ Block -> [KValue]
blkCode Block
b
    f HashSet Identifier
_ KValue
_           = HashSet Identifier
forall a. HashSet a
S.empty
    g :: HashSet a -> a -> HashSet a
g HashSet a
s a
i           = if a -> HashSet a -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member a
i HashSet a
s then HashSet a
forall a. HashSet a
S.empty else a -> HashSet a
forall a. Hashable a => a -> HashSet a
S.singleton a
i
    umap :: HashSet Identifier -> [KValue] -> HashSet Identifier
umap HashSet Identifier
s          = [HashSet Identifier] -> HashSet Identifier
forall a. (Eq a, Hashable a) => [HashSet a] -> HashSet a
S.unions ([HashSet Identifier] -> HashSet Identifier)
-> ([KValue] -> [HashSet Identifier])
-> [KValue]
-> HashSet Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KValue -> HashSet Identifier) -> [KValue] -> [HashSet Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (HashSet Identifier -> KValue -> HashSet Identifier
f HashSet Identifier
s)

-- instances --

class Cmp a where
  cmp :: a -> a -> Ordering

instance Cmp KPrim where
  cmp :: KPrim -> KPrim -> Ordering
cmp (KInt   Integer
x) (KFloat Double
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
x) Double
y
  cmp (KFloat Double
x) (KInt   Integer
y) = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
x (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
y)
  cmp KPrim
x KPrim
y
      | KType
t KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
/= KType
u = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> String -> KException
UncomparableTypes (KType -> String
forall a. IsString a => KType -> a
typeToStr KType
t) (KType -> String
forall a. IsString a => KType -> a
typeToStr KType
u)
      | Bool
otherwise = KPrim -> KPrim -> Ordering
forall a. Ord a => a -> a -> Ordering
compare KPrim
x KPrim
y
    where
      t :: KType
t = KPrim -> KType
typeOfPrim KPrim
x; u :: KType
u = KPrim -> KType
typeOfPrim KPrim
y

instance Cmp KValue where
  cmp :: KValue -> KValue -> Ordering
cmp (KPrim    KPrim
x) (KPrim     KPrim
y) = KPrim -> KPrim -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp KPrim
x KPrim
y
  cmp (KPair    Pair
x) (KPair     Pair
y)
    = (Kwd -> Kwd -> Ordering)
-> (KValue -> KValue -> Ordering)
-> (Kwd, KValue)
-> (Kwd, KValue)
-> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 Kwd -> Kwd -> Ordering
forall a. Ord a => a -> a -> Ordering
compare KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp (Pair -> Kwd
key Pair
x, Pair -> KValue
value Pair
x) (Pair -> Kwd
key Pair
y, Pair -> KValue
value Pair
y)
  cmp (KList    List
x) (KList     List
y)
    = (KValue -> KValue -> Ordering) -> [KValue] -> [KValue] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp (List -> [KValue]
unList List
x) (List -> [KValue]
unList List
y)
  cmp (KDict    Dict
x) (KDict     Dict
y)
    = (Identifier -> Identifier -> Ordering)
-> (KValue -> KValue -> Ordering)
-> DictTable
-> DictTable
-> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 Identifier -> Identifier -> Ordering
forall a. Ord a => a -> a -> Ordering
compare KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp (Dict -> DictTable
unDict Dict
x) (Dict -> DictTable
unDict Dict
y)
  cmp (KRecord  Record
x) (KRecord   Record
y)
    = (RecordT -> RecordT -> Ordering)
-> ([KValue] -> [KValue] -> Ordering)
-> (RecordT, [KValue])
-> (RecordT, [KValue])
-> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 RecordT -> RecordT -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [KValue] -> [KValue] -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp (Record -> RecordT
recType Record
x, Record -> [KValue]
recValues Record
x)
                               (Record -> RecordT
recType Record
y, Record -> [KValue]
recValues Record
y)
  cmp KValue
x KValue
y
      | KType
t KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
/= KType
u = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> String -> KException
UncomparableTypes (KType -> String
forall a. IsString a => KType -> a
typeToStr KType
t) (KType -> String
forall a. IsString a => KType -> a
typeToStr KType
u)
      | KType
t KType -> [KType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KType
TIdent, KType
TQuot, KType
TRecordT] = KValue -> KValue -> Ordering
forall a. Ord a => a -> a -> Ordering
compare KValue
x KValue
y
      | Bool
otherwise = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ KType -> String
forall a. IsString a => KType -> a
typeToStr KType
t
    where
      t :: KType
t = KValue -> KType
typeOf KValue
x; u :: KType
u = KValue -> KType
typeOf KValue
y

instance Cmp [KValue] where
  cmp :: [KValue] -> [KValue] -> Ordering
cmp = (KValue -> KValue -> Ordering) -> [KValue] -> [KValue] -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare KValue -> KValue -> Ordering
forall a. Cmp a => a -> a -> Ordering
cmp

-- TODO: find some way of comparing these?

instance Eq Block where
  Block
_ == :: Block -> Block -> Bool
== Block
_ = KException -> Bool
forall a e. Exception e => e -> a
throw (KException -> Bool) -> KException -> Bool
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"block"

-- TODO
instance Eq Builtin where
  Builtin
_ == :: Builtin -> Builtin -> Bool
== Builtin
_ = KException -> Bool
forall a e. Exception e => e -> a
throw (KException -> Bool) -> KException -> Bool
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"builtin"

instance Eq Multi where
  Multi
_ == :: Multi -> Multi -> Bool
== Multi
_ = KException -> Bool
forall a e. Exception e => e -> a
throw (KException -> Bool) -> KException -> Bool
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"multi"

instance Eq Thunk where
  Thunk
_ == :: Thunk -> Thunk -> Bool
== Thunk
_ = KException -> Bool
forall a e. Exception e => e -> a
throw (KException -> Bool) -> KException -> Bool
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"thunk"

instance Ord Block where
  compare :: Block -> Block -> Ordering
compare Block
_ Block
_ = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"block"

-- TODO
instance Ord Builtin where
  compare :: Builtin -> Builtin -> Ordering
compare Builtin
_ Builtin
_ = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"builtin"

instance Ord Multi where
  compare :: Multi -> Multi -> Ordering
compare Multi
_ Multi
_ = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"multi"

instance Ord Thunk where
  compare :: Thunk -> Thunk -> Ordering
compare Thunk
_ Thunk
_ = KException -> Ordering
forall a e. Exception e => e -> a
throw (KException -> Ordering) -> KException -> Ordering
forall a b. (a -> b) -> a -> b
$ String -> KException
UncomparableType String
"thunk"

instance Show KException where
  show :: KException -> String
show (ParseError String
msg)         = String
"parse error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  show (EvalUnexpected String
t)       = String
"cannot eval " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t
  show (KException
EvalScopelessBlock)     = String
"cannot eval scopeless block"
  show (ModuleNameError String
name)   = String
"no loaded module named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
  show (ModuleLoadError String
name)   = String
"cannot load module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
  show (NameError String
name)         = String
"name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not defined"
  show  KException
StackUnderflow          = String
"stack underflow"
  show (Expected EExpected
e)             = EExpected -> String
forall a. Show a => a -> String
show EExpected
e
  show (MultiMatchFailed String
n String
s)   = String
"no signature " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for multi " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n
  show (UncomparableType String
t)     = String
"type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not comparable"
  show (UncomparableTypes String
t String
u)  = String
"types " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                  String
" are not comparable"
  show (UncallableType String
t)       = String
"type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not callable"
  show (UnapplicableType String
t String
op)  = String
"type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not support " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op
  show (UnknownField String
f String
t)       = String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no field named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f
  show (EmptyList String
op)           = String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": empty list"
  show (IndexError String
op String
i)        = String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is out of range"
  show (KeyError String
op String
k)          = String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
  show (RangeError String
msg)         = String
"range error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  show  KException
DivideByZero            = String
"divide by zero"
  show (InvalidRx String
msg)          = String
"invalid regex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
  show (Fail String
msg)               = String
msg
  show (NotImplemented String
s)       = String
"not implemented: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s

instance Show EExpected where
  show :: EExpected -> String
show (StackExpected String
t String
u)      = String
"expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" on stack (not " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  show (ApplyMissing Bool
b)
      = String
"expected block to have parameter named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op
    where
      (String
x, String
op) = if Bool
b then (String
"&&", String
"apply-dict") else (String
"&", String
"apply")
  show (OtherExpected String
msg)  = String
msg

instance Show Kwd where
  show :: Kwd -> String
show (Kwd Identifier
s) = String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Identifier -> Bool
M.isIdent Identifier
s then Identifier -> String
T.unpack Identifier
s else Identifier -> String
forall a. Show a => a -> String
show Identifier
s

instance Show Ident where
  show :: Ident -> String
show = Identifier -> String
T.unpack (Identifier -> String) -> (Ident -> Identifier) -> Ident -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Identifier
unIdent

instance Show Pair where
  show :: Pair -> String
show (Pair Kwd
k KValue
v) = Kwd -> String
forall a. Show a => a -> String
show Kwd
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ KValue -> String
forall a. Show a => a -> String
show KValue
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =>"

instance Show List where
  show :: List -> String
show (List [])  = String
"()"
  show (List [KValue]
l)   = String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ((KValue -> String) -> [KValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map KValue -> String
forall a. Show a => a -> String
show [KValue]
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" )"

instance Show Dict where
  show :: Dict -> String
show (Dict DictTable
d)
      | DictTable -> Bool
forall k v. HashMap k v -> Bool
H.null DictTable
d  = String
"{ }"
      | Bool
otherwise = String
"{ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
kv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    where
      kv :: [String]
kv        = ((Identifier, KValue) -> String)
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, KValue) -> String
f ([(Identifier, KValue)] -> [String])
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(Identifier, KValue)] -> [(Identifier, KValue)]
forall a. Ord a => [a] -> [a]
sort ([(Identifier, KValue)] -> [(Identifier, KValue)])
-> [(Identifier, KValue)] -> [(Identifier, KValue)]
forall a b. (a -> b) -> a -> b
$ DictTable -> [(Identifier, KValue)]
forall k v. HashMap k v -> [(k, v)]
H.toList DictTable
d
      f :: (Identifier, KValue) -> String
f (Identifier
k, KValue
v)  = Pair -> String
forall a. Show a => a -> String
show (Pair -> String) -> Pair -> String
forall a b. (a -> b) -> a -> b
$ Kwd -> KValue -> Pair
Pair (Identifier -> Kwd
Kwd Identifier
k) KValue
v

-- TODO
instance Show Block where
  show :: Block -> String
show (Block [Ident]
_ [KValue]
_ (Just Scope
s)) | Scope -> Identifier
modName Scope
s Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
bltnModule
    = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Identifier, KValue) -> String)
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (KValue -> String
forall a. Show a => a -> String
show (KValue -> String)
-> ((Identifier, KValue) -> KValue)
-> (Identifier, KValue)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, KValue) -> KValue
forall a b. (a, b) -> b
snd) ([(Identifier, KValue)] -> [String])
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ [(Identifier, KValue)] -> [(Identifier, KValue)]
forall a. Ord a => [a] -> [a]
sort ([(Identifier, KValue)] -> [(Identifier, KValue)])
-> [(Identifier, KValue)] -> [(Identifier, KValue)]
forall a b. (a -> b) -> a -> b
$ DictTable -> [(Identifier, KValue)]
forall k v. HashMap k v -> [(k, v)]
H.toList (DictTable -> [(Identifier, KValue)])
-> DictTable -> [(Identifier, KValue)]
forall a b. (a -> b) -> a -> b
$ Scope -> DictTable
table Scope
s
  show (Block [Ident]
p [KValue]
c Maybe Scope
_) = case ([Ident]
p, [KValue]
c) of
      ([], [])  -> String
"[ ]"
      ([], [KValue]
_ )  -> String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [KValue] -> String
forall a. Show a => [a] -> String
f [KValue]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ]"
      ([Ident]
_ , [])  -> String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Ident] -> String
forall a. Show a => [a] -> String
f [Ident]
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" . ]"
      ([Ident]
_ , [KValue]
_ )  -> String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Ident] -> String
forall a. Show a => [a] -> String
f [Ident]
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" . " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [KValue] -> String
forall a. Show a => [a] -> String
f [KValue]
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ]"
    where
      f :: Show a => [a] -> String
      f :: [a] -> String
f = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show

instance Show Builtin where
  show :: Builtin -> String
show Builtin{Bool
Identifier
Evaluator
biRun :: Evaluator
biName :: Identifier
biPrim :: Bool
biRun :: Builtin -> Evaluator
biName :: Builtin -> Identifier
biPrim :: Builtin -> Bool
..} = String
"#<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
T.unpack Identifier
biName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
    where
      t :: String
t = if Bool
biPrim then String
"primitive" else String
"builtin"

instance Show Multi where
  show :: Multi -> String
show Multi{Int
Identifier
MultiTable
mltTable :: MultiTable
mltName :: Identifier
mltArity :: Int
mltTable :: Multi -> MultiTable
mltName :: Multi -> Identifier
mltArity :: Multi -> Int
..}
    = String
"#<multi:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mltArity String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
T.unpack Identifier
mltName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

instance Show RecordT where
  show :: RecordT -> String
show RecordT{[Identifier]
Identifier
recFields :: [Identifier]
recName :: Identifier
recFields :: RecordT -> [Identifier]
recName :: RecordT -> Identifier
..}
      = String
"#<record-type:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
T.unpack Identifier
recName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")>"
    where
      f :: String
f = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"#" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Identifier -> String) -> [Identifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> String
T.unpack [Identifier]
recFields

instance Show Record where
  show :: Record -> String
show Record{[KValue]
RecordT
recValues :: [KValue]
recType :: RecordT
recValues :: Record -> [KValue]
recType :: Record -> RecordT
..} = Identifier -> String
T.unpack (RecordT -> Identifier
recName RecordT
recType) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"{ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flds String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" }"
    where
      flds :: String
flds      = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((Identifier, KValue) -> String)
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, KValue) -> String
f
                ([(Identifier, KValue)] -> [String])
-> [(Identifier, KValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ [Identifier] -> [KValue] -> [(Identifier, KValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip (RecordT -> [Identifier]
recFields RecordT
recType) [KValue]
recValues
      f :: (Identifier, KValue) -> String
f (Identifier
k, KValue
v)  = Pair -> String
forall a. Show a => a -> String
show (Pair -> String) -> Pair -> String
forall a b. (a -> b) -> a -> b
$ Kwd -> KValue -> Pair
Pair (Identifier -> Kwd
Kwd Identifier
k) KValue
v

-- TODO
instance Show KPrim where
  show :: KPrim -> String
show KPrim
KNil       = String
"nil"
  show (KBool Bool
b)  = if Bool
b then String
"#t" else String
"#f"
  show (KInt Integer
i)   = Integer -> String
forall a. Show a => a -> String
show Integer
i
  show (KFloat Double
f) = Double -> String
forall a. Show a => a -> String
show Double
f
  show (KStr Identifier
s)   = Identifier -> String
showStr Identifier
s
  show (KKwd Kwd
k)   = Kwd -> String
forall a. Show a => a -> String
show Kwd
k

instance Show KValue where
  show :: KValue -> String
show (KPrim KPrim
p)      = KPrim -> String
forall a. Show a => a -> String
show KPrim
p
  show (KPair Pair
p)      = Pair -> String
forall a. Show a => a -> String
show Pair
p
  show (KList List
l)      = List -> String
forall a. Show a => a -> String
show List
l
  show (KDict Dict
d)      = Dict -> String
forall a. Show a => a -> String
show Dict
d
  show (KIdent Ident
i)     = Ident -> String
forall a. Show a => a -> String
show Ident
i
  show (KQuot Ident
i)      = String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
forall a. Show a => a -> String
show Ident
i
  show (KBlock Block
b)     = Block -> String
forall a. Show a => a -> String
show Block
b
  show (KBuiltin Builtin
b)   = Builtin -> String
forall a. Show a => a -> String
show Builtin
b
  show (KMulti Multi
m)     = Multi -> String
forall a. Show a => a -> String
show Multi
m
  show (KRecordT RecordT
r)   = RecordT -> String
forall a. Show a => a -> String
show RecordT
r
  show (KRecord Record
r)    = Record -> String
forall a. Show a => a -> String
show Record
r
  show (KThunk Thunk
_)     = String
"#<thunk>"

instance Show KType where
  show :: KType -> String
show KType
TNil       = String
"#<::nil>"
  show KType
TBool      = String
"#<::bool>"
  show KType
TInt       = String
"#<::int>"
  show KType
TFloat     = String
"#<::float>"
  show KType
TStr       = String
"#<::str>"
  show KType
TKwd       = String
"#<::kwd>"
  show KType
TPair      = String
"#<::pair>"
  show KType
TList      = String
"#<::list>"
  show KType
TDict      = String
"#<::dict>"
  show KType
TIdent     = String
"#<::ident>"
  show KType
TQuot      = String
"#<::quot>"
  show KType
TBlock     = String
"#<::block>"
  show KType
TBuiltin   = String
"#<::builtin>"
  show KType
TMulti     = String
"#<::multi>"
  show KType
TRecordT   = String
"#<::record-type>"
  show KType
TRecord    = String
"#<::record>"
  show KType
TThunk     = String
"#<::thunk>"

showStr :: Text -> String
showStr :: Identifier -> String
showStr Identifier
s = Identifier -> String
T.unpack (Identifier -> String) -> Identifier -> String
forall a b. (a -> b) -> a -> b
$ [Identifier] -> Identifier
T.concat [Identifier
"\"", (Char -> Identifier) -> Identifier -> Identifier
T.concatMap Char -> Identifier
f Identifier
s, Identifier
"\""]
  where
    f :: Char -> Identifier
f Char
c = Identifier
-> (Identifier -> Identifier) -> Maybe Identifier -> Identifier
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Char -> Identifier
g Char
c) Identifier -> Identifier
forall a. a -> a
id (Maybe Identifier -> Identifier) -> Maybe Identifier -> Identifier
forall a b. (a -> b) -> a -> b
$ Char -> [(Char, Identifier)] -> Maybe Identifier
forall a b. Eq a => a -> [(a, b)] -> Maybe b
P.lookup Char
c [(Char, Identifier)]
bsl
    g :: Char -> Identifier
g Char
c = if Char -> Bool
isPrint Char
c then Char -> Identifier
T.singleton Char
c else Int -> Identifier
forall a. (Integral a, Show a) => a -> Identifier
h (Char -> Int
ord Char
c)
    h :: a -> Identifier
h a
n = let (Identifier
p,Int
m) = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0xffff then (Identifier
"\\u",Int
4) else (Identifier
"\\U",Int
8)
          in Identifier
p Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Identifier -> Identifier
T.justifyRight Int
m Char
'0' (String -> Identifier
T.pack (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ a -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex a
n String
"")
    bsl :: [(Char, Identifier)]
bsl = String -> [Identifier] -> [(Char, Identifier)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Identifier -> Char) -> [Identifier] -> String
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> Char
T.head [Identifier]
escapeTo) [Identifier]
escapeFrom

escapeFrom, escapeTo :: [Text]
escapeFrom :: [Identifier]
escapeFrom  = [Identifier
"\\r",Identifier
"\\n",Identifier
"\\t",Identifier
"\\\"",Identifier
"\\\\"]
escapeTo :: [Identifier]
escapeTo    = [ Identifier
"\r", Identifier
"\n", Identifier
"\t",  Identifier
"\"",  Identifier
"\\"]

-- ToVal & FromVal --

class ToVal a where
  toVal :: a -> KValue

instance ToVal () where
  toVal :: () -> KValue
toVal () = KPrim -> KValue
KPrim KPrim
KNil

instance ToVal Bool where
  toVal :: Bool -> KValue
toVal = KPrim -> KValue
KPrim (KPrim -> KValue) -> (Bool -> KPrim) -> Bool -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> KPrim
KBool

instance ToVal Integer where
  toVal :: Integer -> KValue
toVal = KPrim -> KValue
KPrim (KPrim -> KValue) -> (Integer -> KPrim) -> Integer -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> KPrim
KInt

instance ToVal Double where
  toVal :: Double -> KValue
toVal = KPrim -> KValue
KPrim (KPrim -> KValue) -> (Double -> KPrim) -> Double -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> KPrim
KFloat

instance ToVal Text where
  toVal :: Identifier -> KValue
toVal = KPrim -> KValue
KPrim (KPrim -> KValue) -> (Identifier -> KPrim) -> Identifier -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> KPrim
KStr

instance ToVal Kwd where
  toVal :: Kwd -> KValue
toVal = KPrim -> KValue
KPrim (KPrim -> KValue) -> (Kwd -> KPrim) -> Kwd -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kwd -> KPrim
KKwd

instance ToVal Pair where
  toVal :: Pair -> KValue
toVal = Pair -> KValue
KPair

instance ToVal [KValue] where
  toVal :: [KValue] -> KValue
toVal = List -> KValue
KList (List -> KValue) -> ([KValue] -> List) -> [KValue] -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> List
List

instance ToVal [Pair] where
  toVal :: [Pair] -> KValue
toVal = Dict -> KValue
KDict (Dict -> KValue) -> ([Pair] -> Dict) -> [Pair] -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictTable -> Dict
Dict (DictTable -> Dict) -> ([Pair] -> DictTable) -> [Pair] -> Dict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Identifier, KValue)] -> DictTable
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList ([(Identifier, KValue)] -> DictTable)
-> ([Pair] -> [(Identifier, KValue)]) -> [Pair] -> DictTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> (Identifier, KValue)) -> [Pair] -> [(Identifier, KValue)]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> (Identifier, KValue)
f
    where
      f :: Pair -> (Identifier, KValue)
f (Pair (Kwd Identifier
k) KValue
v) = (Identifier
k, KValue
v)

instance ToVal Dict where
  toVal :: Dict -> KValue
toVal = Dict -> KValue
KDict

instance ToVal Block where
  toVal :: Block -> KValue
toVal = Block -> KValue
KBlock

instance ToVal Builtin where
  toVal :: Builtin -> KValue
toVal = Builtin -> KValue
KBuiltin

instance ToVal KValue where
  toVal :: KValue -> KValue
toVal = KValue -> KValue
forall a. a -> a
id

instance ToVal a => ToVal (Maybe a) where
  toVal :: Maybe a -> KValue
toVal = KValue -> Maybe a -> KValue
forall a. ToVal a => KValue -> Maybe a -> KValue
maybeToVal KValue
nil

instance ToVal a => ToVal (Either e a) where
  toVal :: Either e a -> KValue
toVal = KValue -> Either e a -> KValue
forall a e. ToVal a => KValue -> Either e a -> KValue
eitherToVal KValue
nil

-- NB: no ToVal for
-- * ident, quot (both Ident)
-- * multi, record(-type) (no point)

class FromVal a where
  fromVal :: KValue -> Either KException a

instance FromVal () where
  fromVal :: KValue -> Either KException ()
fromVal (KPrim KPrim
KNil)        = () -> Either KException ()
forall a b. b -> Either a b
Right ()
  fromVal KValue
x                   = KException -> Either KException ()
forall a b. a -> Either a b
Left (KException -> Either KException ())
-> KException -> Either KException ()
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"nil"

instance FromVal Bool where
  fromVal :: KValue -> Either KException Bool
fromVal (KPrim (KBool Bool
x))   = Bool -> Either KException Bool
forall a b. b -> Either a b
Right Bool
x
  fromVal KValue
x                   = KException -> Either KException Bool
forall a b. a -> Either a b
Left (KException -> Either KException Bool)
-> KException -> Either KException Bool
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"bool"

instance FromVal Integer where
  fromVal :: KValue -> Either KException Integer
fromVal (KPrim (KInt Integer
x))    = Integer -> Either KException Integer
forall a b. b -> Either a b
Right Integer
x
  fromVal KValue
x                   = KException -> Either KException Integer
forall a b. a -> Either a b
Left (KException -> Either KException Integer)
-> KException -> Either KException Integer
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"int"

instance FromVal Double where
  fromVal :: KValue -> Either KException Double
fromVal (KPrim (KFloat Double
x))  = Double -> Either KException Double
forall a b. b -> Either a b
Right Double
x
  fromVal KValue
x                   = KException -> Either KException Double
forall a b. a -> Either a b
Left (KException -> Either KException Double)
-> KException -> Either KException Double
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"float"

instance FromVal Text where
  fromVal :: KValue -> Either KException Identifier
fromVal (KPrim (KStr Identifier
x))    = Identifier -> Either KException Identifier
forall a b. b -> Either a b
Right Identifier
x
  fromVal KValue
x                   = KException -> Either KException Identifier
forall a b. a -> Either a b
Left (KException -> Either KException Identifier)
-> KException -> Either KException Identifier
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"str"

instance FromVal Kwd where
  fromVal :: KValue -> Either KException Kwd
fromVal (KPrim (KKwd Kwd
x))    = Kwd -> Either KException Kwd
forall a b. b -> Either a b
Right Kwd
x
  fromVal KValue
x                   = KException -> Either KException Kwd
forall a b. a -> Either a b
Left (KException -> Either KException Kwd)
-> KException -> Either KException Kwd
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"kwd"

instance FromVal Pair where
  fromVal :: KValue -> Either KException Pair
fromVal (KPair Pair
x)           = Pair -> Either KException Pair
forall a b. b -> Either a b
Right Pair
x
  fromVal KValue
x                   = KException -> Either KException Pair
forall a b. a -> Either a b
Left (KException -> Either KException Pair)
-> KException -> Either KException Pair
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"pair"

instance FromVal [KValue] where
  fromVal :: KValue -> Either KException [KValue]
fromVal (KList (List [KValue]
x))    = [KValue] -> Either KException [KValue]
forall a b. b -> Either a b
Right [KValue]
x
  fromVal KValue
x                   = KException -> Either KException [KValue]
forall a b. a -> Either a b
Left (KException -> Either KException [KValue])
-> KException -> Either KException [KValue]
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"list"

instance FromVal Dict where
  fromVal :: KValue -> Either KException Dict
fromVal (KDict Dict
x)           = Dict -> Either KException Dict
forall a b. b -> Either a b
Right Dict
x
  fromVal KValue
x                   = KException -> Either KException Dict
forall a b. a -> Either a b
Left (KException -> Either KException Dict)
-> KException -> Either KException Dict
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"dict"

instance FromVal Block where
  fromVal :: KValue -> Either KException Block
fromVal (KBlock Block
x)          = Block -> Either KException Block
forall a b. b -> Either a b
Right Block
x
  fromVal KValue
x                   = KException -> Either KException Block
forall a b. a -> Either a b
Left (KException -> Either KException Block)
-> KException -> Either KException Block
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"block"

instance FromVal Record where
  fromVal :: KValue -> Either KException Record
fromVal (KRecord Record
x)         = Record -> Either KException Record
forall a b. b -> Either a b
Right Record
x
  fromVal KValue
x                   = KException -> Either KException Record
forall a b. a -> Either a b
Left (KException -> Either KException Record)
-> KException -> Either KException Record
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"record"

instance FromVal RecordT where
  fromVal :: KValue -> Either KException RecordT
fromVal (KRecordT RecordT
x)        = RecordT -> Either KException RecordT
forall a b. b -> Either a b
Right RecordT
x
  fromVal KValue
x                   = KException -> Either KException RecordT
forall a b. a -> Either a b
Left (KException -> Either KException RecordT)
-> KException -> Either KException RecordT
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) String
"record-type"

instance FromVal KValue where
  fromVal :: KValue -> Either KException KValue
fromVal KValue
x                   = KValue -> Either KException KValue
forall a b. b -> Either a b
Right KValue
x

instance FromVal a => FromVal (Maybe a) where
  fromVal :: KValue -> Either KException (Maybe a)
fromVal (KPrim KPrim
KNil)        = Maybe a -> Either KException (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
  fromVal KValue
x                   = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> Either KException a -> Either KException (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KValue -> Either KException a
forall a. FromVal a => KValue -> Either KException a
fromVal KValue
x

instance (FromVal a, FromVal b) => FromVal (Either a b) where
  fromVal :: KValue -> Either KException (Either a b)
fromVal KValue
x = case KValue -> Either KException a
forall a. FromVal a => KValue -> Either KException a
fromVal KValue
x of
      Right a
y   -> Either a b -> Either KException (Either a b)
forall a b. b -> Either a b
Right (a -> Either a b
forall a b. a -> Either a b
Left a
y)
      Left KException
e1   -> case KValue -> Either KException b
forall a. FromVal a => KValue -> Either KException a
fromVal KValue
x of
        Right b
y -> Either a b -> Either KException (Either a b)
forall a b. b -> Either a b
Right (b -> Either a b
forall a b. b -> Either a b
Right b
y)
        Left KException
e2 -> KException -> Either KException (Either a b)
forall a b. a -> Either a b
Left (KException -> Either KException (Either a b))
-> KException -> Either KException (Either a b)
forall a b. (a -> b) -> a -> b
$ Either String KValue -> String -> KException
stackExpected (KValue -> Either String KValue
forall a b. b -> Either a b
Right KValue
x) (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ KException -> KException -> String
f KException
e1 KException
e2
    where
      f :: KException -> KException -> String
f (Expected (StackExpected String
t1 String
_))
        (Expected (StackExpected String
t2 String
_)) = String
t1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" or " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t2
      f KException
_ KException
_ = String -> String
forall a. HasCallStack => String -> a
error String
"WTF"

-- NB: no FromVal for
-- * ident, quot (both Ident)
-- * builtin, multi, record-type (no need?)

toVals :: ToVal a => [a] -> [KValue]
toVals :: [a] -> [KValue]
toVals = (a -> KValue) -> [a] -> [KValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> KValue
forall a. ToVal a => a -> KValue
toVal

fromVals :: FromVal a => [KValue] -> Either KException [a]
fromVals :: [KValue] -> Either KException [a]
fromVals = (KValue -> Either KException a)
-> [KValue] -> Either KException [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KValue -> Either KException a
forall a. FromVal a => KValue -> Either KException a
fromVal

maybeToVal :: ToVal a => KValue -> Maybe a -> KValue
maybeToVal :: KValue -> Maybe a -> KValue
maybeToVal = (KValue -> (a -> KValue) -> Maybe a -> KValue)
-> (a -> KValue) -> KValue -> Maybe a -> KValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip KValue -> (a -> KValue) -> Maybe a -> KValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> KValue
forall a. ToVal a => a -> KValue
toVal

eitherToVal :: ToVal a => KValue -> Either e a -> KValue
eitherToVal :: KValue -> Either e a -> KValue
eitherToVal = ((e -> KValue) -> (a -> KValue) -> Either e a -> KValue)
-> (a -> KValue) -> (e -> KValue) -> Either e a -> KValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip (e -> KValue) -> (a -> KValue) -> Either e a -> KValue
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> KValue
forall a. ToVal a => a -> KValue
toVal ((e -> KValue) -> Either e a -> KValue)
-> (KValue -> e -> KValue) -> KValue -> Either e a -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> e -> KValue
forall a b. a -> b -> a
const

-- toJSON & fromJSON --

toJSON :: KValue -> Either KException Text
toJSON :: KValue -> Either KException Identifier
toJSON = (Value -> Identifier)
-> Either KException Value -> Either KException Identifier
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text -> Identifier
LT.toStrict (Text -> Identifier) -> (Value -> Text) -> Value -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LE.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encode) (Either KException Value -> Either KException Identifier)
-> (KValue -> Either KException Value)
-> KValue
-> Either KException Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> Either KException Value
f --  TODO
  where
    f :: KValue -> Either KException Value
f (KPrim KPrim
KNil)        = Value -> Either KException Value
forall a b. b -> Either a b
Right Value
AE.Null
    f (KPrim (KBool Bool
x))   = Value -> Either KException Value
forall a b. b -> Either a b
Right (Value -> Either KException Value)
-> Value -> Either KException Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
AE.Bool Bool
x
    f (KPrim (KInt Integer
x))    = Value -> Either KException Value
forall a b. b -> Either a b
Right (Value -> Either KException Value)
-> Value -> Either KException Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
forall a. ToJSON a => a -> Value
AE.toJSON Integer
x
    f (KPrim (KFloat Double
x))  = Value -> Either KException Value
forall a b. b -> Either a b
Right (Value -> Either KException Value)
-> Value -> Either KException Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
forall a. ToJSON a => a -> Value
AE.toJSON Double
x
    f (KPrim (KStr Identifier
x))    = Value -> Either KException Value
forall a b. b -> Either a b
Right (Value -> Either KException Value)
-> Value -> Either KException Value
forall a b. (a -> b) -> a -> b
$ Identifier -> Value
forall a. ToJSON a => a -> Value
AE.toJSON Identifier
x
    f (KPrim (KKwd Kwd
x))    = Value -> Either KException Value
forall a b. b -> Either a b
Right (Value -> Either KException Value)
-> Value -> Either KException Value
forall a b. (a -> b) -> a -> b
$ Identifier -> Value
forall a. ToJSON a => a -> Value
AE.toJSON (Identifier -> Value) -> Identifier -> Value
forall a b. (a -> b) -> a -> b
$ Kwd -> Identifier
unKwd Kwd
x
    f (KPair (Pair Kwd
k KValue
v))  = KValue -> Either KException Value
f (KValue -> Either KException Value)
-> KValue -> Either KException Value
forall a b. (a -> b) -> a -> b
$ [KValue] -> KValue
forall a. ToVal a => [a] -> KValue
list [KPrim -> KValue
KPrim (KPrim -> KValue) -> KPrim -> KValue
forall a b. (a -> b) -> a -> b
$ Kwd -> KPrim
KKwd (Kwd -> KPrim) -> Kwd -> KPrim
forall a b. (a -> b) -> a -> b
$ Kwd
k, KValue
v]
    f (KList (List [KValue]
x))    = ([Value] -> Value)
-> Either KException [Value] -> Either KException Value
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Value] -> Value
forall a. ToJSON a => a -> Value
AE.toJSON (Either KException [Value] -> Either KException Value)
-> Either KException [Value] -> Either KException Value
forall a b. (a -> b) -> a -> b
$ (KValue -> Either KException Value)
-> [KValue] -> Either KException [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KValue -> Either KException Value
f [KValue]
x
    f (KDict (Dict DictTable
x))    = (Object -> Value)
-> Either KException Object -> Either KException Value
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Object -> Value
AE.Object
                          (Either KException Object -> Either KException Value)
-> Either KException Object -> Either KException Value
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue -> Either KException Value)
-> DictTable -> Either KException Object
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
H.traverseWithKey (\Identifier
_ KValue
v -> KValue -> Either KException Value
f KValue
v) (DictTable -> Either KException Object)
-> DictTable -> Either KException Object
forall a b. (a -> b) -> a -> b
$ DictTable
x
    f (KRecord Record
x)         = KValue -> Either KException Value
f (KValue -> Either KException Value)
-> KValue -> Either KException Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> KValue
dict ([Pair] -> KValue) -> [Pair] -> KValue
forall a b. (a -> b) -> a -> b
$ Record -> [Pair]
recordToPairs Record
x [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++
                            [Kwd -> KValue -> Pair
Pair (Identifier -> Kwd
Kwd Identifier
"__koneko_type__")
                                  (Identifier -> KValue
str (Identifier -> KValue) -> Identifier -> KValue
forall a b. (a -> b) -> a -> b
$ RecordT -> Identifier
recName (RecordT -> Identifier) -> RecordT -> Identifier
forall a b. (a -> b) -> a -> b
$ Record -> RecordT
recType Record
x)]
    f KValue
x = KException -> Either KException Value
forall a b. a -> Either a b
Left (KException -> Either KException Value)
-> KException -> Either KException Value
forall a b. (a -> b) -> a -> b
$ String -> KException
Fail (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ String
"json.<-: cannot convert " String -> String -> String
forall a. [a] -> [a] -> [a]
++ KValue -> String
forall a. IsString a => KValue -> a
typeAsStr KValue
x

fromJSON :: Text -> Either KException KValue
fromJSON :: Identifier -> Either KException KValue
fromJSON  = (String -> KException)
-> (Value -> KValue)
-> Either String Value
-> Either KException KValue
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (String -> KException
Fail (String -> KException)
-> (String -> String) -> String -> KException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"json.<-: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Value -> KValue
f
          (Either String Value -> Either KException KValue)
-> (Identifier -> Either String Value)
-> Identifier
-> Either KException KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
AE.eitherDecodeStrict' (ByteString -> Either String Value)
-> (Identifier -> ByteString) -> Identifier -> Either String Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> ByteString
E.encodeUtf8
  where
    f :: Value -> KValue
f Value
AE.Null         = KValue
nil
    f (AE.Bool Bool
x)     = Bool -> KValue
bool Bool
x
    f x :: Value
x@(AE.Number Scientific
_) = case Value -> Result Integer
forall a. FromJSON a => Value -> Result a
AE.fromJSON Value
x of
                          AE.Success Integer
y    -> Integer -> KValue
int Integer
y
                          AE.Error String
_      -> case Value -> Result Double
forall a. FromJSON a => Value -> Result a
AE.fromJSON Value
x of
                            AE.Success Double
y  -> Double -> KValue
float Double
y
                            AE.Error String
_    -> KValue
nil              --  TODO
    f (AE.String Identifier
x)   = Identifier -> KValue
str Identifier
x
    f (AE.Array  Array
x)   = [KValue] -> KValue
forall a. ToVal a => [a] -> KValue
list ([KValue] -> KValue) -> [KValue] -> KValue
forall a b. (a -> b) -> a -> b
$ (Value -> KValue) -> [Value] -> [KValue]
forall a b. (a -> b) -> [a] -> [b]
map Value -> KValue
f ([Value] -> [KValue]) -> [Value] -> [KValue]
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
x
    f (AE.Object Object
x)   = Dict -> KValue
KDict (Dict -> KValue) -> Dict -> KValue
forall a b. (a -> b) -> a -> b
$ DictTable -> Dict
Dict (DictTable -> Dict) -> DictTable -> Dict
forall a b. (a -> b) -> a -> b
$ (Value -> KValue) -> Object -> DictTable
forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.map Value -> KValue
f Object
x

-- Stack functions --

emptyStack :: Stack
emptyStack :: [KValue]
emptyStack = []

push' :: Stack -> KValue -> Stack
push' :: [KValue] -> KValue -> [KValue]
push' = (KValue -> [KValue] -> [KValue]) -> [KValue] -> KValue -> [KValue]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (:)

push :: ToVal a => Stack -> a -> Stack
push :: [KValue] -> a -> [KValue]
push [KValue]
s = [KValue] -> KValue -> [KValue]
push' [KValue]
s (KValue -> [KValue]) -> (a -> KValue) -> a -> [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> KValue
forall a. ToVal a => a -> KValue
toVal

rpush :: ToVal a => Stack -> [a] -> IO Stack
rpush :: [KValue] -> [a] -> IO [KValue]
rpush [KValue]
s = [KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return ([KValue] -> IO [KValue])
-> ([a] -> [KValue]) -> [a] -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([KValue] -> a -> [KValue]) -> [KValue] -> [a] -> [KValue]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [KValue] -> a -> [KValue]
forall a. ToVal a => [KValue] -> a -> [KValue]
push [KValue]
s

rpush1 :: ToVal a => Stack -> a -> IO Stack
rpush1 :: [KValue] -> a -> IO [KValue]
rpush1 [KValue]
s = [KValue] -> IO [KValue]
forall (m :: * -> *) a. Monad m => a -> m a
return ([KValue] -> IO [KValue]) -> (a -> [KValue]) -> a -> IO [KValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> a -> [KValue]
forall a. ToVal a => [KValue] -> a -> [KValue]
push [KValue]
s

pop_ :: Stack -> Either KException (KValue, Stack)
pop_ :: [KValue] -> Either KException (KValue, [KValue])
pop_ []     = KException -> Either KException (KValue, [KValue])
forall a b. a -> Either a b
Left KException
StackUnderflow
pop_ (KValue
x:[KValue]
s)  = (KValue, [KValue]) -> Either KException (KValue, [KValue])
forall a b. b -> Either a b
Right (KValue
x, [KValue]
s)

pop :: FromVal a => Stack -> Either KException (a, Stack)
pop :: [KValue] -> Either KException (a, [KValue])
pop [KValue]
s = (\(KValue
x, [KValue]
s') -> (,[KValue]
s') (a -> (a, [KValue]))
-> Either KException a -> Either KException (a, [KValue])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KValue -> Either KException a
forall a. FromVal a => KValue -> Either KException a
fromVal KValue
x) ((KValue, [KValue]) -> Either KException (a, [KValue]))
-> Either KException (KValue, [KValue])
-> Either KException (a, [KValue])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [KValue] -> Either KException (KValue, [KValue])
pop_ [KValue]
s

-- | NB: returns popped items in "reverse" order
--
-- >>> s = emptyStack `push` 1 `push` 2
-- >>> fst <$> pop' s :: IO Integer
-- 2
-- >>> fst <$> pop2' s :: IO (Integer, Integer)
-- (1,2)
--
-- stack: ... 1 2 <- top
--
pop2 :: (FromVal a, FromVal b)
     => Stack -> Either KException ((a, b), Stack)
pop2 :: [KValue] -> Either KException ((a, b), [KValue])
pop2 [KValue]
s0 = do
  (b
y, [KValue]
s1) <- [KValue] -> Either KException (b, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s0
  (a
x, [KValue]
s2) <- [KValue] -> Either KException (a, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s1
  ((a, b), [KValue]) -> Either KException ((a, b), [KValue])
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
x, b
y), [KValue]
s2)

-- | NB: returns popped items in "reverse" order
--
-- >>> s = emptyStack `push` 1 `push` 2 `push` 3
-- >>> fst <$> pop3' s :: IO (Integer, Integer, Integer)
-- (1,2,3)
--
-- stack: ... 1 2 3 <- top
--
pop3 :: (FromVal a, FromVal b, FromVal c)
     => Stack -> Either KException ((a, b, c), Stack)
pop3 :: [KValue] -> Either KException ((a, b, c), [KValue])
pop3 [KValue]
s0 = do
  (c
z, [KValue]
s1) <- [KValue] -> Either KException (c, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s0
  (b
y, [KValue]
s2) <- [KValue] -> Either KException (b, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s1
  (a
x, [KValue]
s3) <- [KValue] -> Either KException (a, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s2
  ((a, b, c), [KValue]) -> Either KException ((a, b, c), [KValue])
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
x, b
y, c
z), [KValue]
s3)

pop4 :: (FromVal a, FromVal b, FromVal c, FromVal d)
     => Stack -> Either KException ((a, b, c, d), Stack)
pop4 :: [KValue] -> Either KException ((a, b, c, d), [KValue])
pop4 [KValue]
s0 = do
  (d
z, [KValue]
s1) <- [KValue] -> Either KException (d, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s0
  (c
y, [KValue]
s2) <- [KValue] -> Either KException (c, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s1
  (b
x, [KValue]
s3) <- [KValue] -> Either KException (b, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s2
  (a
w, [KValue]
s4) <- [KValue] -> Either KException (a, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop [KValue]
s3
  ((a, b, c, d), [KValue])
-> Either KException ((a, b, c, d), [KValue])
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
w, b
x, c
y, d
z), [KValue]
s4)

pop_' :: Stack -> IO (KValue, Stack)
pop_' :: [KValue] -> IO (KValue, [KValue])
pop_' = Either KException (KValue, [KValue]) -> IO (KValue, [KValue])
forall a. Either KException a -> IO a
retOrThrow (Either KException (KValue, [KValue]) -> IO (KValue, [KValue]))
-> ([KValue] -> Either KException (KValue, [KValue]))
-> [KValue]
-> IO (KValue, [KValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException (KValue, [KValue])
pop_

pop' :: FromVal a => Stack -> IO (a, Stack)
pop' :: [KValue] -> IO (a, [KValue])
pop' = Either KException (a, [KValue]) -> IO (a, [KValue])
forall a. Either KException a -> IO a
retOrThrow (Either KException (a, [KValue]) -> IO (a, [KValue]))
-> ([KValue] -> Either KException (a, [KValue]))
-> [KValue]
-> IO (a, [KValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException (a, [KValue])
forall a. FromVal a => [KValue] -> Either KException (a, [KValue])
pop

pop2' :: (FromVal a, FromVal b) => Stack -> IO ((a, b), Stack)
pop2' :: [KValue] -> IO ((a, b), [KValue])
pop2' = Either KException ((a, b), [KValue]) -> IO ((a, b), [KValue])
forall a. Either KException a -> IO a
retOrThrow (Either KException ((a, b), [KValue]) -> IO ((a, b), [KValue]))
-> ([KValue] -> Either KException ((a, b), [KValue]))
-> [KValue]
-> IO ((a, b), [KValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException ((a, b), [KValue])
forall a b.
(FromVal a, FromVal b) =>
[KValue] -> Either KException ((a, b), [KValue])
pop2

pop3' :: (FromVal a, FromVal b, FromVal c)
      => Stack -> IO ((a, b, c), Stack)
pop3' :: [KValue] -> IO ((a, b, c), [KValue])
pop3' = Either KException ((a, b, c), [KValue]) -> IO ((a, b, c), [KValue])
forall a. Either KException a -> IO a
retOrThrow (Either KException ((a, b, c), [KValue])
 -> IO ((a, b, c), [KValue]))
-> ([KValue] -> Either KException ((a, b, c), [KValue]))
-> [KValue]
-> IO ((a, b, c), [KValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException ((a, b, c), [KValue])
forall a b c.
(FromVal a, FromVal b, FromVal c) =>
[KValue] -> Either KException ((a, b, c), [KValue])
pop3

pop4' :: (FromVal a, FromVal b, FromVal c, FromVal d)
      => Stack -> IO ((a, b, c, d), Stack)
pop4' :: [KValue] -> IO ((a, b, c, d), [KValue])
pop4' = Either KException ((a, b, c, d), [KValue])
-> IO ((a, b, c, d), [KValue])
forall a. Either KException a -> IO a
retOrThrow (Either KException ((a, b, c, d), [KValue])
 -> IO ((a, b, c, d), [KValue]))
-> ([KValue] -> Either KException ((a, b, c, d), [KValue]))
-> [KValue]
-> IO ((a, b, c, d), [KValue])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException ((a, b, c, d), [KValue])
forall a b c d.
(FromVal a, FromVal b, FromVal c, FromVal d) =>
[KValue] -> Either KException ((a, b, c, d), [KValue])
pop4

popN' :: (FromVal a) => Int -> Stack -> IO ([a], Stack)
popN' :: Int -> [KValue] -> IO ([a], [KValue])
popN' Int
n [KValue]
s0 = if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then ([a], [KValue]) -> IO ([a], [KValue])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [KValue]
s0) else [a] -> Int -> [KValue] -> IO ([a], [KValue])
forall t a.
(Eq t, Num t, FromVal a) =>
[a] -> t -> [KValue] -> IO ([a], [KValue])
f [] Int
n [KValue]
s0
  where
    f :: [a] -> t -> [KValue] -> IO ([a], [KValue])
f [a]
xs t
0 [KValue]
s = ([a], [KValue]) -> IO ([a], [KValue])
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs, [KValue]
s)
    f [a]
xs t
m [KValue]
s = do (a
x, [KValue]
s') <- [KValue] -> IO (a, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s; [a] -> t -> [KValue] -> IO ([a], [KValue])
f (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) (t
mt -> t -> t
forall a. Num a => a -> a -> a
-t
1) [KValue]
s'

pop1push :: (FromVal a, ToVal b) => (a -> [b]) -> Evaluator
pop1push :: (a -> [b]) -> Evaluator
pop1push a -> [b]
f Context
_ [KValue]
s = do (a
x, [KValue]
s') <- [KValue] -> IO (a, [KValue])
forall a. FromVal a => [KValue] -> IO (a, [KValue])
pop' [KValue]
s; [KValue] -> [b] -> IO [KValue]
forall a. ToVal a => [KValue] -> [a] -> IO [KValue]
rpush [KValue]
s' ([b] -> IO [KValue]) -> [b] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ a -> [b]
f a
x

pop2push :: (FromVal a, FromVal b, ToVal c)
         => (a -> b -> [c]) -> Evaluator
pop2push :: (a -> b -> [c]) -> Evaluator
pop2push a -> b -> [c]
f Context
_ [KValue]
s = do ((a
x, b
y), [KValue]
s') <- [KValue] -> IO ((a, b), [KValue])
forall a b.
(FromVal a, FromVal b) =>
[KValue] -> IO ((a, b), [KValue])
pop2' [KValue]
s; [KValue] -> [c] -> IO [KValue]
forall a. ToVal a => [KValue] -> [a] -> IO [KValue]
rpush [KValue]
s' ([c] -> IO [KValue]) -> [c] -> IO [KValue]
forall a b. (a -> b) -> a -> b
$ a -> b -> [c]
f a
x b
y

pop1push1 :: (FromVal a, ToVal b) => (a -> b) -> Evaluator
pop1push1 :: (a -> b) -> Evaluator
pop1push1 a -> b
f = (a -> [b]) -> Evaluator
forall a b. (FromVal a, ToVal b) => (a -> [b]) -> Evaluator
pop1push ((a -> [b]) -> Evaluator) -> (a -> [b]) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \a
x -> [a -> b
f a
x]

pop2push1 :: (FromVal a, FromVal b, ToVal c)
          => (a -> b -> c) -> Evaluator
pop2push1 :: (a -> b -> c) -> Evaluator
pop2push1 a -> b -> c
f = (a -> b -> [c]) -> Evaluator
forall a b c.
(FromVal a, FromVal b, ToVal c) =>
(a -> b -> [c]) -> Evaluator
pop2push ((a -> b -> [c]) -> Evaluator) -> (a -> b -> [c]) -> Evaluator
forall a b. (a -> b) -> a -> b
$ \a
x b
y -> [a -> b -> c
f a
x b
y]

-- Module/Scope functions --

primModule, bltnModule, prldModule, mainModule :: Identifier
primModule :: Identifier
primModule = Identifier
"__prim__"
bltnModule :: Identifier
bltnModule = Identifier
"__bltn__"
prldModule :: Identifier
prldModule = Identifier
"__prld__"
mainModule :: Identifier
mainModule = Identifier
"__main__"

initMainContext :: IO Context
initMainContext :: IO Context
initMainContext = do
  HashTable
  RealWorld Identifier (HashTable RealWorld Identifier KValue)
modules <- IO
  (HashTable
     RealWorld Identifier (HashTable RealWorld Identifier KValue))
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new; HashTable RealWorld Identifier [Identifier]
imports <- IO (HashTable RealWorld Identifier [Identifier])
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new
  let ctxScope :: Scope
ctxScope = Identifier -> Scope
_newScope Identifier
mainModule; ctx :: Context
ctx = Context :: HashTable Identifier Module
-> HashTable Identifier [Identifier] -> Scope -> Context
Context{HashTable RealWorld Identifier [Identifier]
HashTable
  RealWorld Identifier (HashTable RealWorld Identifier KValue)
HashTable Identifier [Identifier]
HashTable Identifier Module
Scope
ctxScope :: Scope
imports :: HashTable RealWorld Identifier [Identifier]
modules :: HashTable
  RealWorld Identifier (HashTable RealWorld Identifier KValue)
imports :: HashTable Identifier [Identifier]
modules :: HashTable Identifier Module
ctxScope :: Scope
..}
  (Identifier -> IO ()) -> [Identifier] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Context -> Identifier -> IO ()
initModule Context
ctx) [Identifier
primModule, Identifier
bltnModule, Identifier
prldModule]
  Context
ctx Context -> IO () -> IO Context
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Context -> IO ()
initMain Context
ctx

initMain :: Context -> IO ()
initMain :: Context -> IO ()
initMain Context
c = do
  Context -> Identifier -> IO ()
initModule Context
c Identifier
mainModule
  let d :: Identifier -> KValue -> IO ()
d = Context -> Identifier -> Identifier -> KValue -> IO ()
defineIn' Context
c Identifier
mainModule
  Identifier -> KValue -> IO ()
d Identifier
"__args__" (KValue -> IO ()) -> KValue -> IO ()
forall a b. (a -> b) -> a -> b
$ List -> KValue
KList (List -> KValue) -> List -> KValue
forall a b. (a -> b) -> a -> b
$ [KValue] -> List
List []; Identifier -> KValue -> IO ()
d Identifier
"__repl__" KValue
false

initModule :: Context -> Identifier -> IO ()
initModule :: Context -> Identifier -> IO ()
initModule Context
ctx Identifier
m = IO (HashTable RealWorld Identifier KValue)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new IO (HashTable RealWorld Identifier KValue)
-> (HashTable RealWorld Identifier KValue -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IOHashTable
  HashTable Identifier (HashTable RealWorld Identifier KValue)
-> Identifier -> HashTable RealWorld Identifier KValue -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert (Context -> HashTable Identifier Module
modules Context
ctx) Identifier
m

forkContext :: Identifier -> Context -> IO Context
forkContext :: Identifier -> Context -> IO Context
forkContext Identifier
m Context
c = do
    (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when IO ()
mkMod (Bool -> IO ()) -> IO Bool -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (HashTable RealWorld Identifier KValue) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (HashTable RealWorld Identifier KValue) -> Bool)
-> IO (Maybe (HashTable RealWorld Identifier KValue)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOHashTable
  HashTable Identifier (HashTable RealWorld Identifier KValue)
-> Identifier -> IO (Maybe (HashTable RealWorld Identifier KValue))
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup (Context -> HashTable Identifier Module
modules Context
c) Identifier
m
    Context -> IO Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
c { ctxScope :: Scope
ctxScope = Identifier -> Scope
_newScope Identifier
m }
  where
    mkMod :: IO ()
mkMod = IO (HashTable RealWorld Identifier KValue)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new IO (HashTable RealWorld Identifier KValue)
-> (HashTable RealWorld Identifier KValue -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IOHashTable
  HashTable Identifier (HashTable RealWorld Identifier KValue)
-> Identifier -> HashTable RealWorld Identifier KValue -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert (Context -> HashTable Identifier Module
modules Context
c) Identifier
m

_newScope :: Identifier -> Scope
_newScope :: Identifier -> Scope
_newScope Identifier
m = Identifier -> DictTable -> Scope
Scope Identifier
m DictTable
forall k v. HashMap k v
H.empty

-- TODO
forkScope :: Args -> Context -> Block -> IO Context
forkScope :: [(Identifier, KValue)] -> Context -> Block -> IO Context
forkScope [(Identifier, KValue)]
l Context
c Block{[KValue]
[Ident]
Maybe Scope
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkScope :: Block -> Maybe Scope
blkCode :: Block -> [KValue]
blkParams :: Block -> [Ident]
..} = do
    Scope
s <- IO Scope -> (Scope -> IO Scope) -> Maybe Scope -> IO Scope
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (KException -> IO Scope
forall e a. Exception e => e -> IO a
throwIO KException
EvalScopelessBlock) Scope -> IO Scope
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Scope
blkScope
    let t0 :: DictTable
t0 = Scope -> DictTable
table Scope
s
        t1 :: DictTable
t1 = DictTable -> DictTable -> DictTable
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
H.union ([(Identifier, KValue)] -> DictTable
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(Identifier, KValue)]
l) (DictTable -> DictTable) -> DictTable -> DictTable
forall a b. (a -> b) -> a -> b
$ (Identifier -> KValue -> Bool) -> DictTable -> DictTable
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
H.filterWithKey Identifier -> KValue -> Bool
forall p. Identifier -> p -> Bool
p DictTable
t0
        t2 :: DictTable
t2 = if [(Identifier, KValue)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Identifier, KValue)]
l Bool -> Bool -> Bool
&& DictTable -> Int
forall k v. HashMap k v -> Int
H.size DictTable
t1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DictTable -> Int
forall k v. HashMap k v -> Int
H.size DictTable
t0 then DictTable
t0 else DictTable
t1
    Context -> IO Context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
c { ctxScope :: Scope
ctxScope = Scope
s { table :: DictTable
table = DictTable
t2 } }
  where
    fv :: HashSet Identifier
fv = [KValue] -> HashSet Identifier
freeVars [KValue]
blkCode; p :: Identifier -> p -> Bool
p Identifier
k p
_ = Identifier -> HashSet Identifier -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
S.member Identifier
k HashSet Identifier
fv

-- TODO: error if already exists (or prim, etc.)
-- throws ModuleNameError
defineIn :: Context -> Identifier -> KValue -> IO ()
defineIn :: Context -> Identifier -> KValue -> IO ()
defineIn Context
c Identifier
k KValue
v = Context -> Identifier -> Identifier -> KValue -> IO ()
defineIn' Context
c (Scope -> Identifier
modName (Scope -> Identifier) -> Scope -> Identifier
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c) Identifier
k KValue
v

-- throws ModuleNameError
defineIn' :: Context -> Identifier -> Identifier -> KValue -> IO ()
defineIn' :: Context -> Identifier -> Identifier -> KValue -> IO ()
defineIn' Context
c Identifier
mn Identifier
k KValue
v = do HashTable RealWorld Identifier KValue
m <- Context -> Identifier -> IO Module
getModule Context
c Identifier
mn; Module -> Identifier -> KValue -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert HashTable RealWorld Identifier KValue
Module
m Identifier
k KValue
v

importIn :: Context -> Identifier -> IO ()
importIn :: Context -> Identifier -> IO ()
importIn Context
c Identifier
k  = HashTable Identifier [Identifier]
-> Identifier
-> (Maybe [Identifier] -> (Maybe [Identifier], ()))
-> IO ()
forall (h :: * -> * -> * -> *) k v a.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a
HT.mutate (Context -> HashTable Identifier [Identifier]
imports Context
c) (Scope -> Identifier
modName (Scope -> Identifier) -> Scope -> Identifier
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c)
              ((Maybe [Identifier] -> (Maybe [Identifier], ())) -> IO ())
-> (Maybe [Identifier] -> (Maybe [Identifier], ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ (,()) (Maybe [Identifier] -> (Maybe [Identifier], ()))
-> (Maybe [Identifier] -> Maybe [Identifier])
-> Maybe [Identifier]
-> (Maybe [Identifier], ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier] -> Maybe [Identifier]
forall a. a -> Maybe a
Just ([Identifier] -> Maybe [Identifier])
-> (Maybe [Identifier] -> [Identifier])
-> Maybe [Identifier]
-> Maybe [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier]
-> ([Identifier] -> [Identifier])
-> Maybe [Identifier]
-> [Identifier]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Identifier
k] (Identifier -> [Identifier] -> [Identifier]
forall a. Eq a => a -> [a] -> [a]
insert Identifier
k)
  where
    insert :: a -> [a] -> [a]
insert a
x [a]
xs = if a
x a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs then [a]
xs else a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs            --  TODO

-- TODO: error if already defined?!
-- throws ModuleNameError or NameError
importFromIn :: Context -> Identifier -> [Identifier] -> IO ()
importFromIn :: Context -> Identifier -> [Identifier] -> IO ()
importFromIn Context
c Identifier
m
  = (Identifier -> IO ()) -> [Identifier] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Identifier -> IO ()) -> [Identifier] -> IO ())
-> (Identifier -> IO ()) -> [Identifier] -> IO ()
forall a b. (a -> b) -> a -> b
$ \Identifier
k -> Context -> Identifier -> KValue -> IO ()
defineIn Context
c Identifier
k (KValue -> IO ()) -> IO KValue -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> Identifier -> Identifier -> IO KValue
lookupModule' Context
c Identifier
k Identifier
m

-- Prim -> Scope* -> Module -> Import* -> Bltn -> Prld
-- throws ModuleNameError
lookup :: Context -> Identifier -> IO (Maybe KValue)
lookup :: Context -> Identifier -> IO (Maybe KValue)
lookup Context
c Identifier
k = do
    [Identifier]
imp <- [Identifier]
-> ([Identifier] -> [Identifier])
-> Maybe [Identifier]
-> [Identifier]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Identifier] -> [Identifier]
forall a. a -> a
id (Maybe [Identifier] -> [Identifier])
-> IO (Maybe [Identifier]) -> IO [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashTable Identifier [Identifier]
-> Identifier -> IO (Maybe [Identifier])
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup (Context -> HashTable Identifier [Identifier]
imports Context
c) Identifier
m
    let bp :: [IO (Maybe KValue)]
bp = (Identifier -> IO (Maybe KValue))
-> [Identifier] -> [IO (Maybe KValue)]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> IO (Maybe KValue)
look [Identifier
bltnModule, Identifier
prldModule]
        mi :: [IO (Maybe KValue)]
mi = [Identifier -> IO (Maybe KValue)
look Identifier
m, [Identifier] -> IO (Maybe KValue)
lookupImp [Identifier]
imp]
    [IO (Maybe KValue)] -> IO (Maybe KValue)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
M.firstJust ([IO (Maybe KValue)] -> IO (Maybe KValue))
-> [IO (Maybe KValue)] -> IO (Maybe KValue)
forall a b. (a -> b) -> a -> b
$ [Identifier -> IO (Maybe KValue)
look Identifier
primModule, Scope -> IO (Maybe KValue)
lookupScope Scope
s] [IO (Maybe KValue)] -> [IO (Maybe KValue)] -> [IO (Maybe KValue)]
forall a. [a] -> [a] -> [a]
++
      if Identifier
m Identifier -> Identifier -> Bool
forall a. Eq a => a -> a -> Bool
== Identifier
prldModule then [IO (Maybe KValue)]
bp else [IO (Maybe KValue)]
mi [IO (Maybe KValue)] -> [IO (Maybe KValue)] -> [IO (Maybe KValue)]
forall a. [a] -> [a] -> [a]
++ [IO (Maybe KValue)]
bp
  where
    s :: Scope
s = Context -> Scope
ctxScope Context
c; m :: Identifier
m = Scope -> Identifier
modName Scope
s; look :: Identifier -> IO (Maybe KValue)
look = Context -> Identifier -> Identifier -> IO (Maybe KValue)
lookupModule Context
c Identifier
k
    lookupScope :: Scope -> IO (Maybe KValue)
lookupScope = Maybe KValue -> IO (Maybe KValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe KValue -> IO (Maybe KValue))
-> (Scope -> Maybe KValue) -> Scope -> IO (Maybe KValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> DictTable -> Maybe KValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Identifier
k (DictTable -> Maybe KValue)
-> (Scope -> DictTable) -> Scope -> Maybe KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scope -> DictTable
table
    lookupImp :: [Identifier] -> IO (Maybe KValue)
lookupImp   = [IO (Maybe KValue)] -> IO (Maybe KValue)
forall (m :: * -> *) a. Monad m => [m (Maybe a)] -> m (Maybe a)
M.firstJust ([IO (Maybe KValue)] -> IO (Maybe KValue))
-> ([Identifier] -> [IO (Maybe KValue)])
-> [Identifier]
-> IO (Maybe KValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> IO (Maybe KValue))
-> [Identifier] -> [IO (Maybe KValue)]
forall a b. (a -> b) -> [a] -> [b]
map Identifier -> IO (Maybe KValue)
look

-- throws ModuleNameError
lookupModule :: Context -> Identifier -> Identifier -> IO (Maybe KValue)
lookupModule :: Context -> Identifier -> Identifier -> IO (Maybe KValue)
lookupModule Context
c Identifier
k Identifier
m = Context -> Identifier -> IO Module
getModule Context
c Identifier
m IO (HashTable RealWorld Identifier KValue)
-> (HashTable RealWorld Identifier KValue -> IO (Maybe KValue))
-> IO (Maybe KValue)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HashTable RealWorld Identifier KValue
 -> Identifier -> IO (Maybe KValue))
-> Identifier
-> HashTable RealWorld Identifier KValue
-> IO (Maybe KValue)
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashTable RealWorld Identifier KValue
-> Identifier -> IO (Maybe KValue)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup Identifier
k

-- throws ModuleNameError or NameError
lookupModule' :: Context -> Identifier -> Identifier -> IO KValue
lookupModule' :: Context -> Identifier -> Identifier -> IO KValue
lookupModule' Context
c Identifier
k Identifier
m = IO KValue -> (KValue -> IO KValue) -> Maybe KValue -> IO KValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO KValue
forall a. IO a
err KValue -> IO KValue
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe KValue -> IO KValue) -> IO (Maybe KValue) -> IO KValue
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Context -> Identifier -> Identifier -> IO (Maybe KValue)
lookupModule Context
c Identifier
k Identifier
m
  where
    err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> KException
NameError (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
k

-- throws ModuleNameError
moduleKeys :: Context -> Identifier -> IO [Identifier]
moduleKeys :: Context -> Identifier -> IO [Identifier]
moduleKeys Context
c Identifier
m = Context -> Identifier -> IO Module
getModule Context
c Identifier
m IO (HashTable RealWorld Identifier KValue)
-> (HashTable RealWorld Identifier KValue -> IO [Identifier])
-> IO [Identifier]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (((Identifier, KValue) -> Identifier)
-> [(Identifier, KValue)] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, KValue) -> Identifier
forall a b. (a, b) -> a
fst ([(Identifier, KValue)] -> [Identifier])
-> IO [(Identifier, KValue)] -> IO [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO [(Identifier, KValue)] -> IO [Identifier])
-> (HashTable RealWorld Identifier KValue
    -> IO [(Identifier, KValue)])
-> HashTable RealWorld Identifier KValue
-> IO [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashTable RealWorld Identifier KValue -> IO [(Identifier, KValue)]
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
HT.toList

-- throws ModuleNameError
getModule :: Context -> Identifier -> IO Module
getModule :: Context -> Identifier -> IO Module
getModule Context
c Identifier
m = IOHashTable
  HashTable Identifier (HashTable RealWorld Identifier KValue)
-> Identifier -> IO (Maybe (HashTable RealWorld Identifier KValue))
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
HT.lookup (Context -> HashTable Identifier Module
modules Context
c) Identifier
m IO (Maybe (HashTable RealWorld Identifier KValue))
-> (Maybe (HashTable RealWorld Identifier KValue)
    -> IO (HashTable RealWorld Identifier KValue))
-> IO (HashTable RealWorld Identifier KValue)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (HashTable RealWorld Identifier KValue)
-> (HashTable RealWorld Identifier KValue
    -> IO (HashTable RealWorld Identifier KValue))
-> Maybe (HashTable RealWorld Identifier KValue)
-> IO (HashTable RealWorld Identifier KValue)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (HashTable RealWorld Identifier KValue)
forall a. IO a
err HashTable RealWorld Identifier KValue
-> IO (HashTable RealWorld Identifier KValue)
forall (m :: * -> *) a. Monad m => a -> m a
return
  where
    err :: IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> KException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> KException
ModuleNameError (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
m

moduleNames :: Context -> IO [Identifier]
moduleNames :: Context -> IO [Identifier]
moduleNames = ([(Identifier, HashTable RealWorld Identifier KValue)]
 -> [Identifier])
-> IO [(Identifier, HashTable RealWorld Identifier KValue)]
-> IO [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Identifier, HashTable RealWorld Identifier KValue) -> Identifier)
-> [(Identifier, HashTable RealWorld Identifier KValue)]
-> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier, HashTable RealWorld Identifier KValue) -> Identifier
forall a b. (a, b) -> a
fst) (IO [(Identifier, HashTable RealWorld Identifier KValue)]
 -> IO [Identifier])
-> (Context
    -> IO [(Identifier, HashTable RealWorld Identifier KValue)])
-> Context
-> IO [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashTable
  RealWorld Identifier (HashTable RealWorld Identifier KValue)
-> IO [(Identifier, HashTable RealWorld Identifier KValue)]
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
HT.toList (HashTable
   RealWorld Identifier (HashTable RealWorld Identifier KValue)
 -> IO [(Identifier, HashTable RealWorld Identifier KValue)])
-> (Context
    -> HashTable
         RealWorld Identifier (HashTable RealWorld Identifier KValue))
-> Context
-> IO [(Identifier, HashTable RealWorld Identifier KValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context
-> HashTable
     RealWorld Identifier (HashTable RealWorld Identifier KValue)
Context -> HashTable Identifier Module
modules

-- type predicates --

typeNames :: [Identifier]
typeNames :: [Identifier]
typeNames = [
    Identifier
"nil", Identifier
"bool", Identifier
"int", Identifier
"float", Identifier
"str", Identifier
"kwd", Identifier
"pair", Identifier
"list",
    Identifier
"dict", Identifier
"ident", Identifier
"quot", Identifier
"block", Identifier
"builtin", Identifier
"multi",
    Identifier
"record-type", Identifier
"record", Identifier
"thunk"
  ]

typeOfPrim :: KPrim -> KType
typeOfPrim :: KPrim -> KType
typeOfPrim KPrim
p = case KPrim
p of
  KPrim
KNil      -> KType
TNil
  KBool Bool
_   -> KType
TBool
  KInt Integer
_    -> KType
TInt
  KFloat Double
_  -> KType
TFloat
  KStr Identifier
_    -> KType
TStr
  KKwd Kwd
_    -> KType
TKwd

typeOf :: KValue -> KType
typeOf :: KValue -> KType
typeOf (KPrim KPrim
p)      = KPrim -> KType
typeOfPrim KPrim
p
typeOf (KPair Pair
_)      = KType
TPair
typeOf (KList List
_)      = KType
TList
typeOf (KDict Dict
_)      = KType
TDict
typeOf (KIdent Ident
_)     = KType
TIdent
typeOf (KQuot Ident
_)      = KType
TQuot
typeOf (KBlock Block
_)     = KType
TBlock
typeOf (KBuiltin Builtin
_)   = KType
TBuiltin
typeOf (KMulti Multi
_)     = KType
TMulti
typeOf (KRecordT RecordT
_)   = KType
TRecordT
typeOf (KRecord Record
_)    = KType
TRecord
typeOf (KThunk Thunk
_)     = KType
TThunk

typeToKwd :: KType -> Kwd
typeToKwd :: KType -> Kwd
typeToKwd = Identifier -> Kwd
Kwd (Identifier -> Kwd) -> (KType -> Identifier) -> KType -> Kwd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KType -> Identifier
forall a. IsString a => KType -> a
typeToStr

typeToStr :: IsString a => KType -> a
typeToStr :: KType -> a
typeToStr KType
TNil        = a
"nil"
typeToStr KType
TBool       = a
"bool"
typeToStr KType
TInt        = a
"int"
typeToStr KType
TFloat      = a
"float"
typeToStr KType
TStr        = a
"str"
typeToStr KType
TKwd        = a
"kwd"
typeToStr KType
TPair       = a
"pair"
typeToStr KType
TList       = a
"list"
typeToStr KType
TDict       = a
"dict"
typeToStr KType
TIdent      = a
"ident"
typeToStr KType
TQuot       = a
"quot"
typeToStr KType
TBlock      = a
"block"
typeToStr KType
TBuiltin    = a
"builtin"
typeToStr KType
TMulti      = a
"multi"
typeToStr KType
TRecordT    = a
"record-type"
typeToStr KType
TRecord     = a
"record"
typeToStr KType
TThunk      = a
"thunk"

typeAsStr :: IsString a => KValue -> a
typeAsStr :: KValue -> a
typeAsStr = KType -> a
forall a. IsString a => KType -> a
typeToStr (KType -> a) -> (KValue -> KType) -> KValue -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf

isNil, isBool, isInt, isFloat, isStr, isKwd, isPair, isList, isDict,
  isIdent, isQuot, isBlock, isBuiltin, isMulti, isRecordT, isRecord,
  isThunk :: KValue -> Bool

isNil :: KValue -> Bool
isNil       = (KType
TNil       KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isBool :: KValue -> Bool
isBool      = (KType
TBool      KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isInt :: KValue -> Bool
isInt       = (KType
TInt       KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isFloat :: KValue -> Bool
isFloat     = (KType
TFloat     KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isStr :: KValue -> Bool
isStr       = (KType
TStr       KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isKwd :: KValue -> Bool
isKwd       = (KType
TKwd       KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isPair :: KValue -> Bool
isPair      = (KType
TPair      KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isList :: KValue -> Bool
isList      = (KType
TList      KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isDict :: KValue -> Bool
isDict      = (KType
TDict      KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isIdent :: KValue -> Bool
isIdent     = (KType
TIdent     KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isQuot :: KValue -> Bool
isQuot      = (KType
TQuot      KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isBlock :: KValue -> Bool
isBlock     = (KType
TBlock     KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isBuiltin :: KValue -> Bool
isBuiltin   = (KType
TBuiltin   KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isMulti :: KValue -> Bool
isMulti     = (KType
TMulti     KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isRecordT :: KValue -> Bool
isRecordT   = (KType
TRecordT   KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isRecord :: KValue -> Bool
isRecord    = (KType
TRecord    KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isThunk :: KValue -> Bool
isThunk     = (KType
TThunk     KType -> KType -> Bool
forall a. Eq a => a -> a -> Bool
==) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf

isCallable, isFunction :: KValue -> Bool
isCallable :: KValue -> Bool
isCallable = (KType -> [KType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KType]
callableTypes) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf
isFunction :: KValue -> Bool
isFunction = (KType -> [KType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KType]
functionTypes) (KType -> Bool) -> (KValue -> KType) -> KValue -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KValue -> KType
typeOf

callableTypes, functionTypes :: [KType]
callableTypes :: [KType]
callableTypes = [KType
TStr, KType
TPair, KType
TList, KType
TDict, KType
TRecord, KType
TThunk] [KType] -> [KType] -> [KType]
forall a. [a] -> [a] -> [a]
++ [KType]
functionTypes
functionTypes :: [KType]
functionTypes = [KType
TBlock, KType
TBuiltin, KType
TMulti, KType
TRecordT]

-- "constructors" --

nil, false, true :: KValue
nil :: KValue
nil   = () -> KValue
forall a. ToVal a => a -> KValue
toVal ()
false :: KValue
false = Bool -> KValue
forall a. ToVal a => a -> KValue
toVal Bool
False
true :: KValue
true  = Bool -> KValue
forall a. ToVal a => a -> KValue
toVal Bool
True

bool :: Bool -> KValue
bool :: Bool -> KValue
bool = Bool -> KValue
forall a. ToVal a => a -> KValue
toVal

int :: Integer -> KValue
int :: Integer -> KValue
int = Integer -> KValue
forall a. ToVal a => a -> KValue
toVal

float :: Double -> KValue
float :: Double -> KValue
float = Double -> KValue
forall a. ToVal a => a -> KValue
toVal

str :: Text -> KValue
str :: Identifier -> KValue
str = Identifier -> KValue
forall a. ToVal a => a -> KValue
toVal

kwd :: Text -> KValue
kwd :: Identifier -> KValue
kwd = Kwd -> KValue
forall a. ToVal a => a -> KValue
toVal (Kwd -> KValue) -> (Identifier -> Kwd) -> Identifier -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Kwd
Kwd

pair :: ToVal a => Kwd -> a -> KValue
pair :: Kwd -> a -> KValue
pair Kwd
k a
v = Pair -> KValue
forall a. ToVal a => a -> KValue
toVal (Pair -> KValue) -> Pair -> KValue
forall a b. (a -> b) -> a -> b
$ Kwd -> KValue -> Pair
Pair Kwd
k (KValue -> Pair) -> KValue -> Pair
forall a b. (a -> b) -> a -> b
$ a -> KValue
forall a. ToVal a => a -> KValue
toVal a
v

list :: ToVal a => [a] -> KValue
list :: [a] -> KValue
list = [KValue] -> KValue
forall a. ToVal a => a -> KValue
toVal ([KValue] -> KValue) -> ([a] -> [KValue]) -> [a] -> KValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> KValue) -> [a] -> [KValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> KValue
forall a. ToVal a => a -> KValue
toVal

dict :: [Pair] -> KValue
dict :: [Pair] -> KValue
dict = [Pair] -> KValue
forall a. ToVal a => a -> KValue
toVal

-- NB: no ToVal for ident, quot

block :: [Ident] -> [KValue] -> Maybe Scope -> KValue
block :: [Ident] -> [KValue] -> Maybe Scope -> KValue
block [Ident]
blkParams [KValue]
blkCode Maybe Scope
blkScope = Block -> KValue
KBlock Block :: [Ident] -> [KValue] -> Maybe Scope -> Block
Block{[KValue]
[Ident]
Maybe Scope
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
..}

-- TODO: multi, record(-type)?

-- utilities --

dictLookup :: String -> Dict -> [Identifier]
           -> Either KException [KValue]
dictLookup :: String -> Dict -> [Identifier] -> Either KException [KValue]
dictLookup String
op (Dict DictTable
h) = (Identifier -> Either KException KValue)
-> [Identifier] -> Either KException [KValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Identifier -> Either KException KValue
f
  where
    f :: Identifier -> Either KException KValue
f Identifier
k = Either KException KValue
-> (KValue -> Either KException KValue)
-> Maybe KValue
-> Either KException KValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (KException -> Either KException KValue
forall a b. a -> Either a b
Left (KException -> Either KException KValue)
-> KException -> Either KException KValue
forall a b. (a -> b) -> a -> b
$ String -> String -> KException
KeyError String
op (String -> KException) -> String -> KException
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
k) KValue -> Either KException KValue
forall a b. b -> Either a b
Right (Maybe KValue -> Either KException KValue)
-> Maybe KValue -> Either KException KValue
forall a b. (a -> b) -> a -> b
$ Identifier -> DictTable -> Maybe KValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Identifier
k DictTable
h

mkPrim, mkBltn :: Identifier -> Evaluator -> Builtin
mkPrim :: Identifier -> Evaluator -> Builtin
mkPrim = Bool -> Identifier -> Evaluator -> Builtin
Builtin Bool
True (Identifier -> Evaluator -> Builtin)
-> (Identifier -> Identifier) -> Identifier -> Evaluator -> Builtin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Identifier
underscored
mkBltn :: Identifier -> Evaluator -> Builtin
mkBltn = Bool -> Identifier -> Evaluator -> Builtin
Builtin Bool
False

defPrim :: Context -> Builtin -> IO ()
defPrim :: Context -> Builtin -> IO ()
defPrim Context
ctx Builtin
f = Context -> Identifier -> KValue -> IO ()
defineIn Context
ctx (Builtin -> Identifier
biName Builtin
f) (KValue -> IO ()) -> KValue -> IO ()
forall a b. (a -> b) -> a -> b
$ Builtin -> KValue
KBuiltin Builtin
f

-- TODO: error if already exists, name not the same
defMulti :: Context -> Identifier -> [Identifier] -> Block -> IO ()
defMulti :: Context -> Identifier -> [Identifier] -> Block -> IO ()
defMulti Context
c Identifier
mn [Identifier]
sig Block
b = do
    HashTable RealWorld Identifier KValue
curMod <- Context -> Identifier -> IO Module
getModule Context
c (Identifier -> IO Module) -> Identifier -> IO Module
forall a b. (a -> b) -> a -> b
$ Scope -> Identifier
modName (Scope -> Identifier) -> Scope -> Identifier
forall a b. (a -> b) -> a -> b
$ Context -> Scope
ctxScope Context
c
    Module
-> Identifier -> (Maybe KValue -> IO (Maybe KValue, ())) -> IO ()
forall (h :: * -> * -> * -> *) k v a.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a
HT.mutateIO HashTable RealWorld Identifier KValue
Module
curMod Identifier
mn Maybe KValue -> IO (Maybe KValue, ())
f
  where
    f :: Maybe KValue -> IO (Maybe KValue, ())
f Maybe KValue
Nothing = do
      HashTable RealWorld [Identifier] Block
mt <- IO (HashTable RealWorld [Identifier] Block)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
HT.new; MultiTable -> [Identifier] -> Block -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert HashTable RealWorld [Identifier] Block
MultiTable
mt [Identifier]
sig Block
b
      (Maybe KValue, ()) -> IO (Maybe KValue, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (KValue -> Maybe KValue
forall a. a -> Maybe a
Just (KValue -> Maybe KValue) -> KValue -> Maybe KValue
forall a b. (a -> b) -> a -> b
$ Multi -> KValue
KMulti (Multi -> KValue) -> Multi -> KValue
forall a b. (a -> b) -> a -> b
$ Int -> Identifier -> MultiTable -> Multi
Multi Int
ma Identifier
mn HashTable RealWorld [Identifier] Block
MultiTable
mt, ())
    f (Just x :: KValue
x@(KMulti Multi{Int
Identifier
MultiTable
mltTable :: MultiTable
mltName :: Identifier
mltArity :: Int
mltTable :: Multi -> MultiTable
mltName :: Multi -> Identifier
mltArity :: Multi -> Int
..})) = (KValue -> Maybe KValue
forall a. a -> Maybe a
Just KValue
x, ()) (Maybe KValue, ()) -> IO () -> IO (Maybe KValue, ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
mltArity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
ma) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
err (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"multi " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
T.unpack Identifier
mltName String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
" to have arity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
mltArity
      MultiTable -> [Identifier] -> Block -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
HT.insert MultiTable
mltTable [Identifier]
sig Block
b
    f Maybe KValue
_ = String -> IO (Maybe KValue, ())
forall a. String -> IO a
err (String -> IO (Maybe KValue, ()))
-> String -> IO (Maybe KValue, ())
forall a b. (a -> b) -> a -> b
$ Identifier -> String
T.unpack Identifier
mn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to be a multi"
    ma :: Int
ma  = [Identifier] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
sig
    err :: String -> IO a
err = KException -> IO a
forall e a. Exception e => e -> IO a
throwIO (KException -> IO a) -> (String -> KException) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> KException
expected

truthy :: KValue -> Bool
truthy :: KValue -> Bool
truthy (KPrim KPrim
KNil)           = Bool
False
truthy (KPrim (KBool Bool
False))  = Bool
False
truthy KValue
_                      = Bool
True

retOrThrow :: Either KException a -> IO a
retOrThrow :: Either KException a -> IO a
retOrThrow = (KException -> IO a) -> (a -> IO a) -> Either KException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either KException -> IO a
forall e a. Exception e => e -> IO a
throwIO a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

recordTypeSig :: RecordT -> Identifier
recordTypeSig :: RecordT -> Identifier
recordTypeSig = String -> Identifier
T.pack (String -> Identifier)
-> (RecordT -> String) -> RecordT -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecordT -> String
forall a. Show a => a -> String
show

underscored :: Text -> Text
underscored :: Identifier -> Identifier
underscored = (Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<> Identifier
"__") (Identifier -> Identifier)
-> (Identifier -> Identifier) -> Identifier -> Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier
"__" Identifier -> Identifier -> Identifier
forall a. Semigroup a => a -> a -> a
<>)

-- TODO
digitParams :: Block -> [Ident]
digitParams :: Block -> [Ident]
digitParams Block{[KValue]
[Ident]
Maybe Scope
blkScope :: Maybe Scope
blkCode :: [KValue]
blkParams :: [Ident]
blkScope :: Block -> Maybe Scope
blkCode :: Block -> [KValue]
blkParams :: Block -> [Ident]
..} = ((Identifier, Int) -> Ident) -> [(Identifier, Int)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Identifier -> Ident
Ident_ (Identifier -> Ident)
-> ((Identifier, Int) -> Identifier) -> (Identifier, Int) -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier, Int) -> Identifier
forall a b. (a, b) -> a
fst) ([(Identifier, Int)] -> [Ident]) -> [(Identifier, Int)] -> [Ident]
forall a b. (a -> b) -> a -> b
$ Int -> [(Identifier, Int)] -> [(Identifier, Int)]
forall a. Int -> [a] -> [a]
take Int
n [(Identifier, Int)]
parms     -- safe!
  where
    n :: Int
n     = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Int] -> [Int]) -> [Maybe Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (Identifier -> Maybe Int) -> [Identifier] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Identifier -> [(Identifier, Int)] -> Maybe Int)
-> [(Identifier, Int)] -> Identifier -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Identifier -> [(Identifier, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
P.lookup [(Identifier, Int)]
parms)
          ([Identifier] -> [Maybe Int]) -> [Identifier] -> [Maybe Int]
forall a b. (a -> b) -> a -> b
$ HashSet Identifier -> [Identifier]
forall a. HashSet a -> [a]
S.toList (HashSet Identifier -> [Identifier])
-> HashSet Identifier -> [Identifier]
forall a b. (a -> b) -> a -> b
$ [KValue] -> HashSet Identifier
freeVars [KValue]
blkCode
    parms :: [(Identifier, Int)]
parms = [ (Identifier -> Identifier
underscored (Identifier -> Identifier) -> Identifier -> Identifier
forall a b. (a -> b) -> a -> b
$ Char -> Identifier
T.singleton (Int -> Char
intToDigit Int
i), Int
i)
            | Int
i <- [Int
1..Int
9] ]

unKwds :: [KValue] -> IO [Identifier]
unKwds :: [KValue] -> IO [Identifier]
unKwds = Either KException [Identifier] -> IO [Identifier]
forall a. Either KException a -> IO a
retOrThrow (Either KException [Identifier] -> IO [Identifier])
-> ([KValue] -> Either KException [Identifier])
-> [KValue]
-> IO [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Kwd] -> [Identifier])
-> Either KException [Kwd] -> Either KException [Identifier]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Kwd -> Identifier) -> [Kwd] -> [Identifier]
forall a b. (a -> b) -> [a] -> [b]
map Kwd -> Identifier
unKwd) (Either KException [Kwd] -> Either KException [Identifier])
-> ([KValue] -> Either KException [Kwd])
-> [KValue]
-> Either KException [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KValue] -> Either KException [Kwd]
forall a. FromVal a => [KValue] -> Either KException [a]
fromVals

recordToPairs :: Record -> [Pair]
recordToPairs :: Record -> [Pair]
recordToPairs Record
r
  = [ Kwd -> KValue -> Pair
Pair (Identifier -> Kwd
Kwd Identifier
k) KValue
v | (Identifier
k, KValue
v) <- [Identifier] -> [KValue] -> [(Identifier, KValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip (RecordT -> [Identifier]
recFields (RecordT -> [Identifier]) -> RecordT -> [Identifier]
forall a b. (a -> b) -> a -> b
$ Record -> RecordT
recType Record
r)
                                     (Record -> [KValue]
recValues Record
r) ]

-- vim: set tw=70 sw=2 sts=2 et fdm=marker :