diff options
| -rw-r--r-- | bruijn.cabal | 3 | ||||
| -rw-r--r-- | package.yaml | 3 | ||||
| -rw-r--r-- | src/Eval.hs | 11 | ||||
| -rw-r--r-- | src/Helper.hs | 12 |
4 files changed, 20 insertions, 9 deletions
diff --git a/bruijn.cabal b/bruijn.cabal index c57167a..5f0ffdb 100644 --- a/bruijn.cabal +++ b/bruijn.cabal @@ -64,6 +64,7 @@ library , bytestring , clock , containers + , deepseq , directory , filepath , haskeline @@ -91,6 +92,7 @@ executable bruijn , bytestring , clock , containers + , deepseq , directory , filepath , haskeline @@ -119,6 +121,7 @@ test-suite bruijn-test , bytestring , clock , containers + , deepseq , directory , filepath , haskeline diff --git a/package.yaml b/package.yaml index 6c7bfc8..794956e 100644 --- a/package.yaml +++ b/package.yaml @@ -33,13 +33,14 @@ dependencies: - bitstring - bytestring - clock -- time - containers +- deepseq - directory - filepath - haskeline - megaparsec - mtl +- time - random library: diff --git a/src/Eval.hs b/src/Eval.hs index c91329c..3ee762f 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -5,6 +5,7 @@ module Eval import Binary import Control.Concurrent +import Control.DeepSeq ( deepseq ) import Control.Exception import Control.Monad.State import qualified Control.Monad.State.Strict as StrictState @@ -266,10 +267,12 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case pure $ EnvState (Environment M.empty) conf (EnvCache M.empty) Time e -> do start <- getTime Monotonic - _ <- evalInstruction (ContextualInstruction (Evaluate e) inp) - s - (const $ pure s) - end <- getTime Monotonic + let (res, _) = evalExp e (Environment M.empty) `runState` env + end <- case res of + Left err -> print err >> getTime Monotonic + Right e' -> do + red <- reduce e' + deepseq red (getTime Monotonic) let roundSecs x = (fromIntegral (round $ x * 1e6 :: Integer)) / 1e6 :: Double putStr diff --git a/src/Helper.hs b/src/Helper.hs index 33bfd69..bf5bc23 100644 --- a/src/Helper.hs +++ b/src/Helper.hs @@ -3,9 +3,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} -- extensions above are only used because of printBundle from megaparsec +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} module Helper where +import Control.DeepSeq ( NFData ) import qualified Control.Monad.State as S import Data.Array import qualified Data.BitString as Bit @@ -13,6 +16,7 @@ import qualified Data.ByteString.Lazy as Byte import qualified Data.ByteString.Lazy.Char8 as C import Data.List import qualified Data.Map as M +import GHC.Generics ( Generic ) import Text.Megaparsec invalidProgramState :: a @@ -104,12 +108,12 @@ printBundle ParseErrorBundle {..} = <> "\n" data MixfixIdentifierKind = MixfixSome String | MixfixNone - deriving (Ord, Eq) + deriving (Ord, Eq, Generic, NFData) instance Show MixfixIdentifierKind where -- don't colorize (due to map) show (MixfixSome e) = e show _ = "…" data Identifier = NormalFunction String | MixfixFunction [MixfixIdentifierKind] | PrefixFunction String | NamespacedFunction String Identifier - deriving (Ord, Eq) + deriving (Ord, Eq, Generic, NFData) functionName :: Identifier -> String functionName = \case NormalFunction f -> f @@ -120,13 +124,13 @@ instance Show Identifier where show ident = "\ESC[95m" <> functionName ident <> "\ESC[0m" data Mixfix = MixfixOperator Identifier | MixfixExpression Expression - deriving (Ord, Eq) + deriving (Ord, Eq, Generic, NFData) instance Show Mixfix where show (MixfixOperator i) = show i show (MixfixExpression e) = show e -- TODO: Remove Application and replace with Chain (renaming of MixfixChain) data Expression = Bruijn Int | Function Identifier | Abstraction Expression | Application Expression Expression | MixfixChain [Mixfix] | Prefix Identifier Expression - deriving (Ord, Eq) + deriving (Ord, Eq, Generic, NFData) instance Show Expression where -- TODO: make use of precedence value? showsPrec _ (Bruijn x) = showString "\ESC[91m" . shows x . showString "\ESC[0m" |