massive cleanup

This commit is contained in:
Mirek Kratochvil 2022-11-26 13:35:19 +01:00
parent 58367975ae
commit a26f0f29c0
9 changed files with 82 additions and 35 deletions

View file

@ -1,17 +1,25 @@
module Builtins where
import Code
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy
import Data.Functor.Identity
( Builtin(..)
, BuiltinFn
, Cho(..)
, Datum(..)
, Instr(..)
, Interp(..)
, heapStruct
)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (get, gets, modify)
import Data.Functor.Identity (runIdentity)
import Data.List (intercalate)
import qualified Data.Map as M
import Env hiding (PrlgEnv)
import Env (PrlgEnv(..), findStruct)
import qualified IR
import Interpreter (backtrack)
import qualified Operators as O
import System.Console.Haskeline
import System.Console.Haskeline (getInputChar, outputStr, outputStrLn)
bi = Builtin

View file

@ -2,11 +2,11 @@
module Code where
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.State.Lazy (StateT)
import qualified Data.Map as M
import IR (Id(..), StrTable)
import Operators (Ops)
import System.Console.Haskeline
import System.Console.Haskeline (InputT)
data Datum
= Atom Int -- unifies a constant
@ -73,6 +73,7 @@ data Builtin =
instance Show Builtin where
show _ = "Builtin _"
-- TODO are we actually going to use this?
codeStruct ::
Monad m
=> (Datum -> m a)

View file

@ -2,19 +2,11 @@ module Compiler where
import Data.Char (isUpper)
import Data.Containers.ListUtils (nubOrd)
import Data.List
import Data.List (elemIndex)
import qualified Data.Map as M
import Code (Code, Datum(..), Instr(..))
import IR (Id(..), PrlgInt(..), PrlgStr(..), StrTable(..), strtablize)
internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
internPrlg = go
where
go t (LiteralS str) = LiteralI <$> strtablize t str
go t (CallS str ps) =
let (t', i) = strtablize t str
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
import IR (Id(..), PrlgInt(..), StrTable(..))
varname :: String -> Bool
varname ('_':_) = True

View file

@ -1,7 +1,7 @@
module Env where
import Code (Interp(..), PrlgEnv)
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.State.Lazy (gets, modify)
import qualified IR
withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a

View file

@ -3,28 +3,28 @@ module Frontend where
import Builtins
import Code (Interp(..))
import qualified Compiler as C
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (evalStateT, gets)
import Data.Foldable (traverse_)
import qualified Data.Map as M
import Env
import Env (PrlgEnv, findAtom, findStruct, withStrTable)
import qualified IR
import qualified Interpreter as I
import qualified Parser as P
import System.Console.Haskeline
import qualified Text.Megaparsec as MP
import Text.Pretty.Simple
import qualified Text.Pretty.Simple as Ppr
ppr :: Show a => a -> PrlgEnv ()
ppr x =
liftIO $
pPrintOpt
CheckColorTty
defaultOutputOptionsDarkBg
{ outputOptionsCompactParens = True
, outputOptionsIndentAmount = 2
, outputOptionsPageWidth = 80
Ppr.pPrintOpt
Ppr.CheckColorTty
Ppr.defaultOutputOptionsDarkBg
{ Ppr.outputOptionsCompactParens = True
, Ppr.outputOptionsIndentAmount = 2
, Ppr.outputOptionsPageWidth = 80
}
x
@ -45,7 +45,7 @@ interpret = (>> return True) . lex
Left err -> lift . outputStrLn $ "expression parsing: " ++ err
Right prlg -> intern prlg
intern prlgs = do
prlgi <- withStrTable $ \st -> C.internPrlg st prlgs
prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
underscore <- findAtom "_"
prlgv <-
withStrTable $ \st ->

View file

@ -1,5 +1,6 @@
module IR where
import Data.List (mapAccumL)
import qualified Data.Map as M
data PrlgStr
@ -31,3 +32,11 @@ strtablize t@(StrTable nxt fwd rev) str =
case fwd M.!? str of
Just i -> (t, i)
_ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt)
internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
internPrlg = go
where
go t (LiteralS str) = LiteralI <$> strtablize t str
go t (CallS str ps) =
let (t', i) = strtablize t str
in CallI (Id i $ length ps) <$> mapAccumL go t' ps

View file

@ -2,7 +2,18 @@
module Interpreter where
import Code
( Builtin(..)
, Cho(..)
, Code
, Datum(..)
, Heap(..)
, Instr(..)
, Interp(..)
, emptyHeap
, emptyScope
)
import qualified Control.Monad.Trans.State.Lazy as St
import Env (PrlgEnv)
--import Data.Function
import qualified Data.Map as M

View file

@ -1,7 +1,7 @@
module Main where
import Frontend (interpreter)
import System.Console.Haskeline
import System.Console.Haskeline (defaultSettings, runInputT)
main :: IO ()
main = runInputT defaultSettings interpreter

View file

@ -8,14 +8,40 @@ module Parser
import Control.Monad (void)
import Data.Char
( isAlpha
, isAlphaNum
, isMark
, isNumber
, isPunctuation
, isSpace
, isSymbol
)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.Split (splitOn)
import Data.Void
import Data.Void (Void)
import Text.Megaparsec
import Text.Megaparsec.Char
( Parsec
, PosState(..)
, SourcePos(..)
, TraversableStream(..)
, VisualStream(..)
, (<|>)
, choice
, eof
, many
, mkPos
, notFollowedBy
, oneOf
, satisfy
, single
, some
, try
, unPos
)
import Text.Megaparsec.Char (string)
import IR (PrlgStr(..))
import Operators
import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
singleToks = ",;|()[]"