Data commit

Task/S-expressions/Haskell/s-expressions-1.hs

@@ -0,0 +1,40 @@
+import qualified Data.Functor.Identity as F
+import qualified Text.Parsec.Prim as Prim
+import Text.Parsec
+       ((<|>), (<?>), many, many1, char, try, parse, sepBy, choice,
+        between)
+import Text.Parsec.Token
+       (integer, float, whiteSpace, stringLiteral, makeTokenParser)
+import Text.Parsec.Char (noneOf)
+import Text.Parsec.Language (haskell)
+
+data Val
+  = Int Integer
+  | Float Double
+  | String String
+  | Symbol String
+  | List [Val]
+  deriving (Eq, Show)
+
+tProg :: Prim.ParsecT String a F.Identity [Val]
+tProg = many tExpr <?> "program"
+  where
+    tExpr = between ws ws (tList <|> tAtom) <?> "expression"
+    ws = whiteSpace haskell
+    tAtom =
+      (try (Float <$> float haskell) <?> "floating point number") <|>
+      (try (Int <$> integer haskell) <?> "integer") <|>
+      (String <$> stringLiteral haskell <?> "string") <|>
+      (Symbol <$> many1 (noneOf "()\"\t\n\r ") <?> "symbol") <?>
+      "atomic expression"
+    tList = List <$> between (char '(') (char ')') (many tExpr) <?> "list"
+
+p :: String -> IO ()
+p = either print (putStrLn . unwords . map show) . parse tProg ""
+
+main :: IO ()
+main = do
+  let expr =
+        "((data \"quoted data\" 123 4.5)\n  (data (!@# (4.5) \"(more\" \"data)\")))"
+  putStrLn ("The input:\n" ++ expr ++ "\n\nParsed as:")
+  p expr

Task/S-expressions/Haskell/s-expressions-2.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE TupleSections #-}
+
+import Data.Bifunctor (bimap)
+import Data.List (mapAccumL)
+import Data.List.Split (splitOn)
+import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
+import Data.Tree (Forest, Tree (..), drawForest)
+
+------------------------ DATA TYPE -----------------------
+data Val
+  = Int Integer
+  | Float Double
+  | String String
+  | Symbol String
+  | List [Val]
+  deriving (Eq, Show, Read)
+
+instance Semigroup Val where
+  List a <> List b = List (a <> b)
+
+instance Monoid Val where
+  mempty = List []
+
+--------------------------- MAIN -------------------------
+main :: IO ()
+main = do
+  let expr =
+        unlines
+          [ "((data \"quoted data\" 123 4.5)",
+            "  (data (!@# (4.5) \"(more\" \"data)\")))"
+          ]
+      parse = fst (parseExpr (tokenized expr))
+
+  putStrLn $ treeDiagram $ forestFromVal parse
+  putStrLn "Serialized from the parse tree:\n"
+  putStrLn $ litVal parse
+
+------------------- S-EXPRESSION PARSER ------------------
+
+parseExpr :: [String] -> (Val, [String])
+parseExpr = until finished parseToken . (mempty,)
+
+finished :: (Val, [String]) -> Bool
+finished (_, []) = True
+finished (_, token : _) = ")" == token
+
+parseToken :: (Val, [String]) -> (Val, [String])
+parseToken (v, "(" : rest) =
+  bimap
+    ((v <>) . List . return)
+    tail
+    (parseExpr rest)
+parseToken (v, ")" : rest) = (v, rest)
+parseToken (v, t : rest) = (v <> List [atom t], rest)
+
+----------------------- TOKEN PARSER ---------------------
+
+atom :: String -> Val
+atom [] = mempty
+atom s@('"' : _) =
+  fromMaybe mempty (maybeRead ("String " <> s))
+atom s =
+  headDef (Symbol s) $
+    catMaybes $
+      maybeRead . (<> (' ' : s)) <$> ["Int", "Float"]
+
+maybeRead :: String -> Maybe Val
+maybeRead = fmap fst . listToMaybe . reads
+
+----------------------- TOKENIZATION ---------------------
+
+tokenized :: String -> [String]
+tokenized s = quoteTokens '"' s >>= go
+  where
+    go [] = []
+    go token@('"' : _) = [token]
+    go s = words $ spacedBrackets s
+
+quoteTokens :: Char -> String -> [String]
+quoteTokens q s = snd $ mapAccumL go False (splitOn [q] s)
+  where
+    go b s
+      | b = (False, '"' : s <> "\"")
+      | otherwise = (True, s)
+
+spacedBrackets :: String -> String
+spacedBrackets [] = []
+spacedBrackets (c : cs)
+  | c `elem` "()" = ' ' : c : " " <> spacedBrackets cs
+  | otherwise = c : spacedBrackets cs
+
+------------------------- DIAGRAMS -----------------------
+
+treeDiagram :: Forest Val -> String
+treeDiagram = drawForest . fmap (fmap show)
+
+forestFromVal :: Val -> Forest Val
+forestFromVal (List xs) = treeFromVal <$> xs
+
+treeFromVal :: Val -> Tree Val
+treeFromVal (List xs) =
+  Node (Symbol "List") (treeFromVal <$> xs)
+treeFromVal v = Node v []
+
+---------------------- SERIALISATION ---------------------
+
+litVal (Symbol x) = x
+litVal (Int x) = show x
+litVal (Float x) = show x
+litVal (String x) = '"' : x <> "\""
+litVal (List [List xs]) = litVal (List xs)
+litVal (List xs) = '(' : (unwords (litVal <$> xs) <> ")")
+
+------------------------- GENERIC ------------------------
+
+headDef :: a -> [a] -> a
+headDef d [] = d
+headDef _ (x : _) = x