diff options
| -rw-r--r-- | app/Main.hs | 2 | ||||
| -rw-r--r-- | examples/test.lisp | 4 | ||||
| -rw-r--r-- | lang.cabal | 3 | ||||
| -rw-r--r-- | package.yaml | 1 | ||||
| -rw-r--r-- | src/Lib.hs | 97 | ||||
| -rw-r--r-- | src/Types.hs | 44 | ||||
| -rw-r--r-- | src/Utils.hs | 2 | ||||
| -rw-r--r-- | stack.yaml | 4 | ||||
| -rw-r--r-- | stack.yaml.lock | 14 |
9 files changed, 139 insertions, 32 deletions
diff --git a/app/Main.hs b/app/Main.hs index 1829c62..978cafc 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,7 @@ repl config = do result <- lift $ runExceptT $ runReaderT (runInlineScript input) config case result of Left (LException ex) -> outputStrLn $ "Error: " ++ ex - Right () -> outputStrLn $ input + Right () -> return () repl config main :: IO () diff --git a/examples/test.lisp b/examples/test.lisp index a84d887..b753827 100644 --- a/examples/test.lisp +++ b/examples/test.lisp @@ -3,4 +3,6 @@ foo ; test1 1 2 ) "string with space" -"another \n\"string\""
\ No newline at end of file +"another \n\"string\"" +(let id + (\[a] a)) @@ -38,6 +38,7 @@ library , containers , haskeline ==0.8.2 , mtl + , regex-tdfa ==1.3.2 default-language: Haskell2010 executable lang-exe @@ -53,6 +54,7 @@ executable lang-exe , haskeline ==0.8.2 , lang , mtl + , regex-tdfa ==1.3.2 default-language: Haskell2010 test-suite lang-test @@ -69,4 +71,5 @@ test-suite lang-test , haskeline ==0.8.2 , lang , mtl + , regex-tdfa ==1.3.2 default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 894f5f4..7a2296c 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ dependencies: - containers - mtl - haskeline == 0.8.2 +- regex-tdfa == 1.3.2 ghc-options: - -Wall @@ -5,34 +5,13 @@ module Lib ( import qualified Data.Map as M import qualified Data.Bifunctor as B +import qualified Data.List as L import Control.Monad.Except import Control.Monad.Reader -import Data.List -import Debug.Trace -import System.Console.Haskeline +import Text.Regex.TDFA import Types import Utils -data AST - = ASTNumber Double - | ASTSymbol String - | ASTBoolean Bool - | ASTString String - | ASTVector [AST] - | ASTHashMap (M.Map AST AST) - | ASTFunction (AST -> AST) - -instance (Show AST) where - show (ASTNumber n) = show n - show (ASTSymbol s) = show s - show (ASTBoolean b) = show b - show (ASTString s) = show s - show (ASTVector v) = "[" ++ intercalate " " (map show v) ++ "]" - show (ASTHashMap m) = - let flattenMap = M.assocs .> map (\(k, v) -> [k, v]) .> concat - in "[" ++ intercalate " " (map show $ flattenMap m) ++ "]" - show (ASTFunction _) = "<fn>" - _tokenize :: [String] -> String -> String -> LContext [String] _tokenize acc current src = case src of "" -> return $ reverse current : acc @@ -53,13 +32,14 @@ _tokenize acc current src = case src of [] -> ("", -1) (string, stringLength) = consume xs stringDropped = drop (stringLength) xs + withQuotes = "\"" ++ string ++ "\"" in do when (stringLength == -1) $ throwError (LException "Unbalanced string literal") - _tokenize (string : acc) "" stringDropped + _tokenize (withQuotes : acc) "" stringDropped | x `elem` [' ', '\n', '\t', '\r'] -> _tokenize (reverse current : acc) "" xs | x `elem` ['(', ')', '[', ']', '{', '}', '\\'] -> - _tokenize ([x] : acc) "" xs + _tokenize ([x] : reverse current : acc) "" xs | otherwise -> _tokenize acc (x : current) xs @@ -70,8 +50,66 @@ tokenize src = do $> reverse .> filter (\s -> length s > 0) -parse :: [String] -> [AST] -parse src = [] +validateBalance :: [String] -> [AST] -> LContext [AST] +validateBalance allowed asts = do + when (ASTSymbol "(" `elem` asts && "(" `notElem` allowed) + $ throwError $ LException "Unbalanced function call" + when (ASTSymbol "[" `elem` asts && "[" `notElem` allowed) + $ throwError $ LException "Unbalanced vector" + when (ASTSymbol "{" `elem` asts && "{" `notElem` allowed) + $ throwError $ LException "Unbalanced hash map" + return asts + +asPairs :: [a] -> LContext [(a, a)] +asPairs [] = return [] +asPairs (a:b:rest) = do + restPaired <- asPairs rest + return $ (a, b) : restPaired +asPairs _ = throwError $ LException "Odd number of elements to pair up" + +parseToken :: String -> AST +parseToken token + | isNumber token = ASTNumber (read token) + | isString token = ASTString $ removeQuotes token + | isBoolean token = ASTBoolean $ asBoolean token + | otherwise = ASTSymbol token + where + numberRegex = "^-?[[:digit:]]+(\\.[[:digit:]]+)?$" + isNumber :: String -> Bool + isNumber t = t =~ numberRegex + isString t = "\"" `L.isPrefixOf` t + removeQuotes s = drop 1 s $> take (length s - 2) + isBoolean t = t `elem` ["true", "false"] + asBoolean t = if t == "true" then True else False + +_parse :: [AST] -> [String] -> LContext [AST] +_parse acc' [] = do + acc <- validateBalance [] acc' + return $ reverse acc +_parse acc (")":rest) = do + let children' = takeWhile (/= ASTSymbol "(") acc + children <- validateBalance ["("] children' + let fnCall = ASTFunctionCall (reverse children) + let newAcc = fnCall : drop (length children + 1) acc + _parse newAcc rest +_parse acc ("]":rest) = do + let children' = takeWhile (/= ASTSymbol "[") acc + children <- validateBalance ["["] children' + let vec = ASTVector (reverse children) + let newAcc = vec : drop (length children + 1) acc + _parse newAcc rest +_parse acc ("}":rest) = do + let children' = takeWhile (/= ASTSymbol "{") acc + children <- validateBalance ["{"] children' + pairs <- asPairs $ reverse children + let vec = ASTHashMap (M.fromList pairs) + let newAcc = vec : drop (length children + 1) acc + _parse newAcc rest +_parse acc (token:rest) = + _parse (parseToken token : acc) rest + +parse :: [String] -> LContext [AST] +parse = _parse [] runScriptFile :: String -> LContext () runScriptFile fileName = do @@ -83,5 +121,6 @@ runInlineScript src = do tokenized <- tokenize src config <- ask when (configVerboseMode config) $ liftIO $ putStrLn $ "tokenized:\t\t" ++ show tokenized - let parsed = parse tokenized - return () + parsed <- parse tokenized + when (configVerboseMode config) $ liftIO $ putStrLn $ "parsed:\t\t\t" ++ show parsed + liftIO $ mapM_ putStrLn (map show parsed) diff --git a/src/Types.hs b/src/Types.hs index 94428b6..5779845 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,7 +1,11 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} module Types where import Control.Monad.Except import Control.Monad.Reader +import qualified Data.Map as M +import qualified Data.List as L +import Utils newtype LException = LException String data Config = Config { @@ -11,3 +15,43 @@ data Config = Config { } type LContext a = ReaderT Config (ExceptT LException IO) a + +data AST + = ASTNumber Double + | ASTSymbol String + | ASTBoolean Bool + | ASTString String + | ASTVector [AST] + | ASTFunctionCall [AST] + | ASTHashMap (M.Map AST AST) + | ASTFunction (AST -> AST) + +instance (Show AST) where + show (ASTNumber n) = show n + show (ASTSymbol s) = s + show (ASTBoolean b) = show b + show (ASTString s) = show s + show (ASTVector v) = "[" ++ L.intercalate " " (map show v) ++ "]" + show (ASTFunctionCall v) = "(" ++ L.intercalate " " (map show v) ++ ")" + show (ASTHashMap m) = + let flattenMap = M.assocs .> map (\(k, v) -> [k, v]) .> concat + in "{" ++ L.intercalate " " (map show $ flattenMap m) ++ "}" + show (ASTFunction _) = "<fn>" + +instance (Eq AST) where + ASTNumber a == ASTNumber b = a == b + ASTSymbol a == ASTSymbol b = a == b + ASTBoolean a == ASTBoolean b = a == b + ASTString a == ASTString b = a == b + ASTVector a == ASTVector b = a == b + ASTHashMap a == ASTHashMap b = a == b + _ == _ = False + +instance (Ord AST) where + ASTNumber a <= ASTNumber b = a <= b + ASTSymbol a <= ASTSymbol b = a <= b + ASTBoolean a <= ASTBoolean b = a <= b + ASTString a <= ASTString b = a <= b + ASTVector a <= ASTVector b = a <= b + ASTHashMap a <= ASTHashMap b = a <= b + _ <= _ = False diff --git a/src/Utils.hs b/src/Utils.hs index 2497c9f..227e120 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} module Utils where (.>) = flip (.) @@ -5,4 +5,6 @@ resolver: compiler: ghc-9.4.2 require-stack-version: ==2.7.5 extra-deps: - - haskeline-0.8.2
\ No newline at end of file + - haskeline-0.8.2 + - regex-base-0.94.0.2 + - regex-tdfa-1.3.2
\ No newline at end of file diff --git a/stack.yaml.lock b/stack.yaml.lock index 5200f97..81770bd 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,4 +11,18 @@ packages: sha256: a51f2be1d61d077b8c972d762e9799983f08c95cae5123cf8ade8803e3250579 original: hackage: haskeline-0.8.2 +- completed: + hackage: regex-base-0.94.0.2@sha256:4ff4425c710cddf440dfbac6cd52310bb6b23e17902390ff71c9fc7eaafc4fcc,2643 + pantry-tree: + size: 531 + sha256: 6415af6c7af19d83283a19407cbf9ece0dc9cf9be9a0d9560d0456247cfa0d00 + original: + hackage: regex-base-0.94.0.2 +- completed: + hackage: regex-tdfa-1.3.2@sha256:3d8571a5ce87ee89ae0de602f1461df9a8236257f80548e9bee71585a26e3927,6845 + pantry-tree: + size: 2674 + sha256: 2725c8313eaf9dc1403f27b691b02143aa6ec546adaea7ab5c985b0f9a777014 + original: + hackage: regex-tdfa-1.3.2 snapshots: [] |