Initial WIP

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/
diff --git a/AST.hs b/AST.hs
new file mode 100644
index 0000000..f8f3624
--- /dev/null
+++ b/AST.hs
@@ -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)
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..72f36b2
--- /dev/null
+++ b/Main.hs
@@ -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