examples: add SmallPython example, and haskell skeleton

examples/ExprLang.hs

@@ -28,7 +28,7 @@ Implemented using the patterns found in:
 Willis & Wu - Design patterns for parser combinators (functional pearl)
 https://dl.acm.org/doi/10.1145/3471874.3472984
 -}
-module ExprLang where
+module Main where
 
 import           ExprLang.Parser (program, expr)
 import ExprLang.AST
@@ -38,6 +38,10 @@ import           Text.Gigaparsec (Parsec, Result (..), parseFromFile, parse)
 import System.IO.Error (userError)
 import Control.Exception (throwIO)
 
+main :: IO ()
+main = do
+  parseFilePretty =<< readLn
+
 
 parseFile :: FilePath -> IO Program
 parseFile f = do

examples/Haskell.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = pure ()

examples/Haskell/AST.hs

@@ -0,0 +1 @@
+module Haskell.AST where

examples/Haskell/AST/ToHaskell.hs

@@ -0,0 +1 @@
+module Haskell.AST.ToHaskell where

examples/Haskell/Lexer.hs

@@ -0,0 +1 @@
+module Haskell.Lexer where

examples/Haskell/Lexer/Description.hs

@@ -0,0 +1 @@
+module Haskell.Lexer.Description where

examples/Haskell/Parser.hs

@@ -0,0 +1 @@
+module Haskell.Parser where

examples/SmallPython.hs

@@ -0,0 +1,33 @@
+{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
+
+
+module Main (main) where
+
+import SmallPython.AST
+import SmallPython.Parser
+import SmallPython.Lexer
+
+import Text.Pretty.Simple
+
+import Text.Gigaparsec
+import SmallPython.AST.ToPython (ToPython(..))
+
+
+main :: IO ()
+main = return ()
+
+
+parseFile :: FilePath -> IO ()
+parseFile fp = do
+  prog <- parseFromFile @String program fp
+  case prog of
+    Failure err -> putStrLn err
+    Success p -> pPrint p
+
+parseFilePretty :: FilePath -> IO ()
+parseFilePretty fp = do
+  prog <- parseFromFile @String program fp
+  case prog of
+    Failure err -> putStrLn err
+    Success p -> putStrLn $ toPythonString p
+

examples/SmallPython/AST.hs

@@ -0,0 +1,165 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE Safe #-}
+{-# OPTIONS_GHC -Wno-missing-kind-signatures #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+-- See
+-- https://docs.python.org/3/reference/grammar.html
+
+module SmallPython.AST where
+
+import Data.List.NonEmpty (NonEmpty ((:|)))
+
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Text.Gigaparsec.Position (Pos)
+import Text.Gigaparsec (Parsec)
+import Text.Gigaparsec.Position (pos)
+import Data.Functor ((<&>))
+
+type Name = String
+type Params = [(Name, Maybe Expr)]
+type TypeParams = ()
+
+
+newtype ParseInfo = ParseInfo Pos
+  deriving (Show, Eq)
+{-# inline parseInfo #-}
+parseInfo :: Parsec ParseInfo
+parseInfo = ParseInfo <$> pos
+
+newtype Program = Program Stats
+  deriving (Show, Eq)
+
+data AssignType = 
+    AssignSimple
+  | AssignPlus
+  deriving (Show, Eq)
+
+-- | A python program is a series of statements, 
+-- which have some effect on the state or control flow of the program.
+data Stat = 
+    StatFunctionDef ParseInfo Name Params Stats1
+  | StatPass ParseInfo
+  | StatAssign ParseInfo AssignType ExprLHS Expr
+  | StatReturn ParseInfo Expr
+  | StatExp ParseInfo Expr
+  deriving (Show, Eq)
+
+type Stats = [Stat]
+type Stats1 = NonEmpty Stat
+
+mkFunctionDef :: Parsec Name -> Parsec Params -> Parsec Stats1 -> Parsec Stat
+mkFunctionDef f xs body = StatFunctionDef <$> parseInfo <*> f <*> xs <*> body
+
+mkStatExp :: Parsec Expr -> Parsec Stat
+mkStatExp expr = StatExp <$> parseInfo <*> expr
+
+mkStatAssign :: Parsec ExprLHS -> Parsec AssignType -> Parsec Expr -> Parsec Stat
+mkStatAssign pLhs pAsgn pExpr = do
+  info <- parseInfo
+  lhs <- pLhs
+  asgn <- pAsgn
+  StatAssign info asgn lhs <$> pExpr
+
+mkReturn :: Parsec Expr -> Parsec Stat
+mkReturn x = StatReturn <$> parseInfo <*> x
+
+-- mkStats :: Parsec (NonEmpty Stat) -> Parsec Stat
+-- mkStats = (<&> \case
+--   x :| [] -> x
+--   xs -> StatSeq xs)
+
+-- | Binary operators that may appear between two expressions
+data BinOpSymbol = 
+    BinPlus
+  | BinMinus
+  | BinMult
+  | BinDiv
+  | BinFloorDiv
+  | BinExponent
+  deriving (Show, Eq)
+
+type BinOp = (ParseInfo, BinOpSymbol)
+
+pattern BinOp :: ParseInfo -> BinOpSymbol -> BinOp
+pattern BinOp p op = (p, op)
+
+mkBinOp :: BinOpSymbol -> Parsec BinOp
+mkBinOp op = (`BinOp` op) <$> parseInfo
+
+-- | Unary prefix operators on expressions
+data UnaryOpSymbol = 
+    UnaryPlus
+  | UnaryMinus
+  deriving (Show, Eq)
+type UnaryOp = (ParseInfo, UnaryOpSymbol)
+
+pattern UnaryOp :: ParseInfo -> UnaryOpSymbol -> UnaryOp
+pattern UnaryOp p op = (p, op)
+
+mkUnaryOp :: UnaryOpSymbol -> Parsec UnaryOp
+mkUnaryOp op = (`UnaryOp` op) <$> parseInfo
+
+
+data AtomNumber =
+    AtomInt    !Integer
+  | AtomDouble !Double
+  deriving (Show, Eq)
+
+-- | Atoms are the most basic expressions; think of literals and variables.
+data Atom =
+    AtomNumber AtomNumber
+  | AtomChar   !Char
+  | AtomString !String
+  | AtomVar    !Name
+  deriving (Show, Eq)
+
+mkAtomNumber :: Parsec AtomNumber -> Parsec Atom
+mkAtomNumber x = AtomNumber <$> x
+
+mkAtomVar :: Parsec Name -> Parsec Atom
+mkAtomVar x = AtomVar <$> x
+
+
+-- | Expressions: these occupy the rhs of statements.
+data Expr = 
+    ExprAtom  ParseInfo Atom
+  | ExprBin   ParseInfo BinOp Expr Expr
+  | ExprUnary ParseInfo UnaryOp Expr
+  | ExprFunctionCall ParseInfo Expr [Expr]
+  deriving (Show, Eq)
+
+mkExprAtom :: Parsec Atom -> Parsec Expr
+mkExprAtom = (ExprAtom <$> parseInfo <*>)
+
+mkExprBin :: Parsec (BinOp -> Expr -> Expr -> Expr)
+mkExprBin = ExprBin <$> parseInfo
+
+mkFunctionCall :: Parsec Expr -> Parsec [Expr] -> Parsec Expr
+mkFunctionCall p ps = ExprFunctionCall <$> parseInfo <*> p <*> ps
+
+-- | Expressions that can appear on the LHS of assignment statements.
+data ExprLHS = 
+    LHSIdent Name
+  deriving (Show, Eq)
+
+-- TODO: need to test that all ops are covered
+{-# noinline binOpMap #-}
+binOpMap :: Map String BinOpSymbol
+binOpMap = [
+  ("+",  BinPlus),
+  ("-",  BinMinus),
+  ("*",  BinMult),
+  ("/",  BinDiv),
+  ("//", BinFloorDiv),
+  ("**", BinExponent)
+  ]
+
+{-# noinline unaryOpMap #-}
+unaryOpMap :: Map String UnaryOpSymbol
+unaryOpMap = [
+    ("+", UnaryPlus),
+    ("-", UnaryMinus)
+  ]