diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | AST.hs | 52 | ||||
| -rw-r--r-- | Main.hs | 5 | ||||
| -rw-r--r-- | Parser.hs | 137 | ||||
| -rw-r--r-- | hs-visinter.cabal | 24 |
5 files changed, 219 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c33954f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ @@ -0,0 +1,52 @@ +module AST where + + +data Program t = Program [FunDef t] + deriving (Show) + +data FunDef t = FunDef Name (Maybe Type) [FunEq t] + deriving (Show) + +newtype Name = Name String + deriving (Show) + +data Type + = TApp Name [Type] + | TTup [Type] + | TList Type + | TFun Type Type + deriving (Show) + +data FunEq t = FunEq Name [Pattern t] (RHS t) + deriving (Show) + +data Pattern t + = PWildcard t + | PVar t Name + | PAs t Name (Pattern t) + | PCon t Name [Pattern t] + | PList t [Pattern t] + | PTup t [Pattern t] + deriving (Show) + +data RHS t + = Guarded [(Expr t, Expr t)] + | Plain (Expr t) + deriving (Show) + +data Expr t + = ELit t Literal + | EList t [Expr t] + | ETup t [Expr t] + | EApp t (Expr t) (Expr t) + | EOp t (Expr t) Operator (Expr t) + | EIf t (Expr t) (Expr t) (Expr t) + | ECase t (Expr t) [(Pattern t, RHS t)] + | ELet t [FunDef t] (Expr t) + deriving (Show) + +data Literal = LInt Int | LFloat Double | LChar Char | LString String + deriving (Show) + +data Operator = OAdd | OSub | OMul | ODiv | OMod + deriving (Show) @@ -0,0 +1,5 @@ +module Main where + + +main :: IO () +main = putStrLn "hoi" diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..420e2b8 --- /dev/null +++ b/Parser.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Parser where + +import Control.Applicative +import Data.Char (isSpace) +import Control.Monad.Chronicle +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Foldable (asum) +import Data.These + +import AST + + +-- Positions are zero-based in both dimensions +data PS = PS + { psRefCol :: Int + , psLine :: Int + , psCol :: Int + , psRest :: String } + deriving (Show) + +data Context = Context { ctxFile :: FilePath } + deriving (Show) + +type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS)) + +-- Positions are zero-based in both dimensions +data ErrMsg = ErrMsg { errFile :: FilePath + , errLine :: Int + , errCol :: Int + , errMsg :: String } + deriving (Show) + +printErrMsg :: ErrMsg -> String +printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s + +parse :: FilePath -> String -> These [ErrMsg] (Program ()) +parse fp source = + flip evalState (PS 0 0 0 source) + . runChronicleT + . flip runReaderT (Context fp) + $ pProgram + +pProgram :: Parser (Program ()) +pProgram = do + prog <- Program <$> many pFunDef + skipWhiteComment + assertEOF Error + return prog + +pFunDef :: Parser (FunDef ()) +pFunDef = _ + + + +data Fatality = Error | Fatal + deriving (Show) + +raise :: Fatality -> String -> Parser () +raise fat msg = do + fp <- asks ctxFile + ps <- get + let fun = case fat of + Error -> dictate . pure + Fatal -> confess . pure + fun (ErrMsg fp (psLine ps) (psCol ps) msg) + +assertEOF :: Fatality -> Parser () +assertEOF fat = gets psRest >>= \case + [] -> return () + _ -> raise fat "Unexpected stuff" + +data ReadResult a = Token a | Truncated a + deriving (Show, Functor) + +readInline :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String) +readInline f s0 = do + ps0 <- get + when (psCol ps0 <= psRefCol ps0) $ + raise Fatal "Expected stuff, but found end of indented expression" + let loop :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String) + loop f' st = do + ps <- get + case psRest ps of + c : cs | Just st' <- f' st c -> do + put (ps { psCol = psCol ps + 1, psRest = cs }) + fmap (c :) <$> loop f' st' + | otherwise -> return (Token "") + [] -> return (Truncated "") + loop f s0 + +skipWhiteComment :: Parser () +skipWhiteComment = do + inlineWhite + _ <- many (inlineComment >> inlineWhite) + _ <- optional lineComment + (consumeNewline >> skipWhiteComment) <|> return () + where + inlineWhite :: Parser () + inlineWhite = readWhileInline isSpace + + inlineComment :: Parser () + inlineComment = do + string "{-" + let loop = do + readWhileInline (`notElem` "{-") + asum [string "-}" + ,inlineComment >> loop + ,consumeNewline >> loop] + loop + + lineComment :: Parser () + lineComment = string "--" >> readWhileInline (const True) + + readWhileInline :: (Char -> Bool) -> Parser () + readWhileInline p = do + (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest + modify (\ps -> ps { psCol = psCol ps + length taken + , psRest = rest }) + +consumeNewline :: Parser () +consumeNewline = gets psRest >>= \case + '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1 + , psCol = 0 + , psRest = rest }) + _ -> empty + +string :: String -> Parser () +string s | any (== '\n') s = error "Newline in 'string' argument" +string s = do + ps <- get + if take (length s) (psRest ps) == s + then put (ps { psCol = psCol ps + length s + , psRest = drop (length s) (psRest ps) }) + else empty diff --git a/hs-visinter.cabal b/hs-visinter.cabal new file mode 100644 index 0000000..ba035ab --- /dev/null +++ b/hs-visinter.cabal @@ -0,0 +1,24 @@ +cabal-version: 2.0 +name: hs-visinter +synopsis: Visualising interpreter for a subset of Haskell +version: 0.1.0.0 +license: MIT +author: Tom Smeding +maintainer: tom@tomsmeding.com +build-type: Simple + +executable hs-visinter + main-is: Main.hs + other-modules: + AST + Parser + build-depends: + base >= 4.13 && < 4.15, + containers >= 0.6.3.1 && < 0.7, + parsec >= 3.1.14.0 && < 3.2, + mtl, + monad-chronicle ^>= 1.0.0.1, + these + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded |