feat: purescript step1

impls/purs/Makefile

@@ -4,4 +4,5 @@ src/step%:
 
 #####################
 
-step0_repl.purs = Mal.Step0
+step0_repl.purs = Mal.Step0
+step1_read_print.purs = Mal.Step1

impls/purs/spago.dhall

@@ -11,7 +11,24 @@ When creating a new Spago project, you can use
 to generate this file without the comments in this block.
 -}
 { name = "mal-purescript"
-, dependencies = [ "console", "effect", "prelude", "psci-support" ]
+, dependencies =
+  [ "arrays"
+  , "console"
+  , "control"
+  , "effect"
+  , "either"
+  , "foldable-traversable"
+  , "integers"
+  , "lists"
+  , "maybe"
+  , "ordered-collections"
+  , "parsing"
+  , "prelude"
+  , "psci-support"
+  , "refs"
+  , "strings"
+  , "tuples"
+  ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs", "test/**/*.purs" ]
 }

impls/purs/src/Printer.purs

@@ -0,0 +1,81 @@
+module Printer where
+
+import Prelude
+
+import Data.List (List(..), (:))
+import Data.Map (toUnfoldable)
+import Data.Maybe (Maybe(..))
+import Data.String.CodeUnits (singleton)
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Effect.Ref as Ref
+import Types (Key(..), MalExpr(..), flatTuples, flatStrings, stringToCharList)
+
+
+
+-- PRINT STRING
+
+printStr :: MalExpr -> Effect String
+printStr MalNil             = pure "nil"
+printStr (MalBoolean b)     = pure $ show b
+printStr (MalInt n)         = pure $ show n
+printStr (MalString str)    = pure $ "\"" <> (str # stringToCharList # map unescape # flatStrings) <> "\""
+printStr (MalKeyword key)   = pure key
+printStr (MalAtom _ r)      = "(atom " <<> (Ref.read r >>= printStr) <>> ")"
+printStr (MalSymbol name)   = pure name
+printStr (MalList _ xs)     = "(" <<> printList xs <>> ")"
+printStr (MalVector _ vs)   = "[" <<> printList vs <>> "]"
+printStr (MalHashMap _ hm)  = "{" <<> (hm # toUnfoldable # flatTuples # printList) <>> "}"
+printStr (MalFunction _)    = pure "#<function>"
+
+
+printList :: List MalExpr -> Effect String
+printList Nil     = pure ""
+printList (x:Nil) = printStr x
+printList (x:xs)  = printStr x <> pure " " <> printList xs
+
+
+
+-- PRINT STRING READABLY
+
+printStrReadably :: MalExpr -> Effect String
+printStrReadably (MalString str)   = pure str
+printStrReadably (MalList _ xs)    = "(" <<> printListReadably " " xs <>> ")"
+printStrReadably (MalVector _ vs)  = "[" <<> printListReadably " " vs <>> "]"
+printStrReadably (MalHashMap _ hm) = "{" <<> (hm # toUnfoldable # flatTuples # printListReadably " ") <>> "}"
+printStrReadably ex                = printStr ex
+
+
+printListReadably :: String -> List MalExpr ->  Effect String
+printListReadably _ Nil      = pure ""
+printListReadably _ (x:Nil)  = printStrReadably x
+printListReadably sep (x:xs) = printStrReadably x <> pure sep <> printListReadably sep xs
+
+
+
+-- UTILS
+
+unescape :: Char -> String
+unescape '\n' = "\\n"
+unescape '\\' = "\\\\"
+unescape '"'  = "\\\""
+unescape c    = singleton c
+
+
+keyValuePairs :: List MalExpr -> Maybe (List (Tuple Key MalExpr))
+keyValuePairs Nil                      = pure Nil
+keyValuePairs (MalString k : v : kvs)  = (:) (Tuple (StringKey k) v) <$> keyValuePairs kvs
+keyValuePairs (MalKeyword k : v : kvs) = (:) (Tuple (KeywordKey k) v) <$> keyValuePairs kvs
+keyValuePairs _                        = Nothing
+
+
+leftConcat :: forall m s. Bind m => Applicative m => Semigroup s => s -> m s -> m s
+leftConcat op f = (<>) <$> pure op <*> f
+
+infixr 5 leftConcat as <<>
+
+
+rightConcat :: forall m s. Apply m => Semigroup s => Applicative m => m s -> s -> m s
+rightConcat f cl = (<>) <$> f <*> pure cl
+
+infixr 5 rightConcat as <>>

impls/purs/src/Reader.purs

@@ -0,0 +1,171 @@
+module Reader (readStr) where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Control.Lazy (fix)
+import Data.Either (Either(..))
+import Data.Int (fromString)
+import Data.List (List(..), many, (:))
+import Data.Maybe (Maybe(..), fromMaybe)
+import Printer (keyValuePairs)
+import Text.Parsing.Parser (Parser, runParser)
+import Text.Parsing.Parser.Combinators (endBy, skipMany, skipMany1, try)
+import Text.Parsing.Parser.String (char, noneOf, oneOf, string)
+import Text.Parsing.Parser.Token (digit, letter)
+import Types (MalExpr(..), charListToString, listToMap, toHashMap, toList, toVector)
+
+
+spaces :: Parser String Unit
+spaces = skipMany1 $ oneOf [',', ' ', '\n']
+
+
+comment :: Parser String Unit
+comment = char ';' *> (skipMany $ noneOf [ '\r', '\n' ])
+
+
+ignored :: Parser String Unit
+ignored = skipMany $ spaces <|> comment
+
+
+symbol :: Parser String Char
+symbol = oneOf ['!', '#', '$', '%', '&', '|', '*', '+', '-', '/', ':', '<', '=', '>', '?', '@', '^', '_', '~']
+
+
+nat :: Parser String Int
+nat = do
+  first <- digit
+  rest <- many digit
+  pure <<< fromMaybe 0 <<< fromString <<< charListToString $ first : rest
+
+
+escape :: Parser String Char
+escape = char '\\'
+      *> oneOf ['\\', '\"', 'n']
+     <#> case _ of
+          'n' -> '\n'
+          x   -> x
+
+
+nonEscape :: Parser String Char
+nonEscape =  noneOf [ '\"', '\\' ]
+
+
+
+-- ATOM
+
+readAtom :: Parser String MalExpr
+readAtom = readNumber
+       <|> try readNegativeNumber
+       <|> readString
+       <|> readKeyword
+       <|> readSymbol
+
+
+readNumber :: Parser String MalExpr
+readNumber = MalInt <$> nat
+
+
+readNegativeNumber :: Parser String MalExpr
+readNegativeNumber = MalInt <<< negate <$> (char '-' *> nat)
+
+
+readString :: Parser String MalExpr
+readString = MalString <$> charListToString <$> (char '"' *> many (escape <|> nonEscape) <* char '"')
+
+
+readKeyword :: Parser String MalExpr
+readKeyword =
+  MalKeyword <$> charListToString
+             <$> ((:) ':')
+             <$> (char ':' *> many (letter <|> digit <|> symbol))
+
+
+readSymbol :: Parser String MalExpr
+readSymbol = f <$> (letter <|> symbol) <*> many (letter <|> digit <|> symbol)
+  where
+
+  f first rest = charListToString (first:rest)
+    # case _ of
+      "true"  -> MalBoolean true
+      "false" -> MalBoolean false
+      "nil"   -> MalNil
+      s       -> MalSymbol s
+
+
+
+--
+
+readList :: Parser String MalExpr
+readList = fix $ \_ ->
+  toList <$> (char '(' *> ignored *> endBy readForm ignored <* char ')')
+
+
+
+--
+
+readVector :: Parser String MalExpr
+readVector = fix $ \_ ->
+  toVector <$> (char '[' *> ignored *> endBy readForm ignored <* char ']')
+
+
+
+--
+
+readHashMap :: Parser String MalExpr
+readHashMap = fix $ \_
+  -> char '{' *> ignored *> endBy readForm ignored <* char '}'
+  <#> keyValuePairs
+  <#> case _ of
+    Just ts -> toHashMap $ listToMap ts
+    Nothing -> MalString "hash map error" -- FIXME: error
+
+
+
+-- MACROS
+
+readMacro :: Parser String MalExpr
+readMacro = fix $ \_ ->
+      macro "\'" "quote"
+  <|> macro "`" "quasiquote"
+  <|> try (macro "~@" "splice-unquote")
+  <|> macro "~" "unquote"
+  <|> macro "@" "deref"
+  <|> readWithMeta
+
+
+macro :: String -> String -> Parser String MalExpr
+macro tok sym = addPrefix sym <$> (string tok *> readForm)
+  where
+
+  addPrefix :: String -> MalExpr -> MalExpr
+  addPrefix s x = toList $ MalSymbol s : x : Nil
+
+
+readWithMeta :: Parser String MalExpr
+readWithMeta = addPrefix <$> (char '^' *> readForm) <*> readForm
+  where
+
+  addPrefix :: MalExpr -> MalExpr -> MalExpr
+  addPrefix m x = toList $ MalSymbol "with-meta" : x : m : Nil
+
+
+
+--
+
+readForm :: Parser String MalExpr
+readForm = fix $ \_ -> ignored
+   *> ( readMacro
+    <|> readList
+    <|> readVector
+    <|> readHashMap
+    <|> readAtom)
+
+
+
+--
+
+readStr :: String -> Either String MalExpr
+readStr str = case runParser str readForm of
+  Left err  -> Left $ show err
+  Right val -> Right val

impls/purs/src/Types.purs

@@ -0,0 +1,128 @@
+module Types where
+
+import Prelude
+
+import Data.Array as Array
+import Data.Foldable (class Foldable)
+import Data.List (List(..), foldr, (:))
+import Data.List as List
+import Data.Map (Map)
+import Data.Map.Internal as Map
+import Data.Maybe (Maybe(..))
+import Data.String.CodeUnits (fromCharArray, toCharArray)
+import Data.Traversable (foldl)
+import Data.Tuple (Tuple(..))
+import Effect (Effect)
+import Effect.Ref (Ref)
+import Effect.Ref as Ref
+
+
+data MalExpr
+  = MalNil
+  | MalBoolean Boolean
+  | MalInt Int
+  | MalString String
+  | MalKeyword String
+  | MalSymbol String
+  | MalAtom Meta (Ref MalExpr)
+  | MalList Meta (List MalExpr)
+  | MalVector Meta (List MalExpr)
+  | MalHashMap Meta (Map Key MalExpr)
+  | MalFunction { fn :: MalFn
+                , params :: List String
+                , macro :: Boolean
+                , meta :: MalExpr
+                }
+
+instance Eq MalExpr where
+  eq MalNil MalNil                     = true
+  eq (MalBoolean a) (MalBoolean b)     = a == b
+  eq (MalInt a) (MalInt b)             = a == b
+  eq (MalString a) (MalString b)       = a == b
+  eq (MalKeyword a) (MalKeyword b)     = a == b
+  eq (MalSymbol a) (MalSymbol b)       = a == b
+
+  eq (MalList _ a) (MalList _ b)       = a == b
+  eq (MalVector _ a) (MalList _ b)     = a == b
+  eq (MalList _ a) (MalVector _ b)     = a == b
+
+  eq (MalVector _ a) (MalVector _ b)   = a == b
+  eq (MalHashMap _ a) (MalHashMap _ b) = a == b
+  eq _ _                               = false
+
+
+data Key = StringKey String
+         | KeywordKey String
+
+derive instance Eq Key
+derive instance Ord Key
+
+
+type MalFn = List MalExpr -> Effect MalExpr
+
+
+type Local = Map String MalExpr
+type RefEnv = List (Ref.Ref Local)
+
+
+
+-- Metas
+
+newtype Meta = Meta MalExpr
+
+
+toList :: List MalExpr -> MalExpr
+toList = MalList (Meta MalNil)
+
+
+toVector :: List MalExpr -> MalExpr
+toVector = MalVector (Meta MalNil)
+
+
+toAtom :: Ref MalExpr -> MalExpr
+toAtom = MalAtom (Meta MalNil)
+
+
+toHashMap :: Map Key MalExpr -> MalExpr
+toHashMap = MalHashMap (Meta MalNil)
+
+
+
+-- Utils
+
+listToMap :: List (Tuple Key MalExpr) -> Map Key MalExpr
+listToMap = Map.fromFoldable
+
+
+charListToString :: List Char -> String
+charListToString = fromCharArray <<< Array.fromFoldable
+
+
+stringToCharList :: String -> List Char
+stringToCharList = List.fromFoldable <<< toCharArray
+
+
+flatStrings :: List String -> String
+flatStrings = foldr (<>) ""
+
+
+flatTuples :: List (Tuple Key MalExpr) -> List MalExpr
+flatTuples ((Tuple (StringKey a) b) : xs)  = MalString a : b : flatTuples xs
+flatTuples ((Tuple (KeywordKey a) b) : xs) = MalKeyword a : b : flatTuples xs
+flatTuples _                               = Nil
+
+
+foldrM :: forall a m b f. Foldable f => Monad m => (a -> b -> m b) -> b -> f a -> m b
+foldrM f z0 xs = foldl c pure xs z0
+  where c k x z = f x z >>= k
+
+
+keyToString :: Key -> MalExpr
+keyToString (StringKey k)  = MalString k
+keyToString (KeywordKey k) = MalKeyword k
+
+
+keyValuePairs :: List MalExpr -> Maybe (List (Tuple String MalExpr))
+keyValuePairs Nil                     = pure Nil
+keyValuePairs (MalString k : v : kvs) = (:)  (Tuple k v) <$> keyValuePairs kvs
+keyValuePairs _                       = Nothing

impls/purs/src/step1_read_print.purs

@@ -0,0 +1,58 @@
+module Mal.Step1 where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Effect (Effect)
+import Effect.Console (error, log)
+import Reader (readStr)
+import Printer (printStr)
+import Readline (readLine)
+import Types (MalExpr)
+
+
+-- READ
+
+read :: String -> Either String MalExpr
+read = readStr
+
+
+
+-- EVAL
+
+eval :: MalExpr -> MalExpr
+eval s = s
+
+
+
+-- PRINT
+
+print :: MalExpr -> Effect String
+print = printStr
+
+
+
+-- REPL
+
+rep :: String -> Effect Unit
+rep str = case read str of
+  Left _  -> error "EOF"
+  Right s -> eval s # print >>= log
+
+
+loop :: Effect Unit
+loop = do
+  line <- readLine "user> "
+  case line of
+    ":q" -> pure unit
+    ":Q" -> pure unit
+    _    -> do
+      rep line
+      loop
+
+
+
+--
+
+main :: Effect Unit
+main = loop