S-expressions: Difference between revisions

Or, parsing by hand (rather than with a parser combinator library) and printing a parse tree diagram:

<lang haskell>{-# LANGUAGE TupleSections #-}

import Data.Bifunctor (bimap)

import Data.List (mapAccumL)

import Data.Maybe (catMaybes, fromMaybe, listToMaybe)

import Data.Tree (Forest, Tree (..), drawForest)

------------------------ DATA TYPE -----------------------

data Val

| 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 ()

]

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) =

parseToken (v, ")" : rest) = (v, rest)

parseToken (v, t : rest) = (v <> List [atom t], rest)

----------------------- TOKEN PARSER ---------------------

atom :: String -> Val

atom [] = mempty

catMaybes $

maybeRead . (<> (' ' : s)) <$> ["Int", "Float"]

maybeRead :: String -> Maybe Val

maybeRead = fmap fst . listToMaybe . reads

----------------------- TOKENIZATION ---------------------

tokenized :: String -> [String]

tokenized s = quoteTokens '"' s >>= go

go token@('"' : _) = [token]

go s = words $ spacedBrackets s

quoteTokens :: Char -> String -> [String]

quoteTokens q s = snd $ mapAccumL go False (splitOn [q] s)

| b = (False, '"' : s <> "\"")

| otherwise = (True, s)

spacedBrackets :: String -> String

spacedBrackets [] = []

| c `elem` "()" = ' ' : c : " " <> spacedBrackets cs

| otherwise = c : spacedBrackets cs

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 []

litVal (Symbol x) = x

litVal (Int x) = show x

litVal (List [List xs]) = litVal (List xs)

litVal (List xs) = '(' : (unwords (litVal <$> xs) <> ")")

------------------------- GENERIC ------------------------

headDef :: a -> [a] -> a

headDef d [] = d