diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/melody.cabal b/melody.cabal new file mode 100644 --- /dev/null +++ b/melody.cabal @@ -0,0 +1,60 @@ +name: melody +version: 0.2 +synopsis: A functional scripting language + +description: A scripting language meant to replace + shell modeled after Joy. + +license: MIT +license-file: LICENSE +author: Danny Gratzer + +maintainer: danny.gratzer@gmail.com + +category: Language + +build-type: Simple + +cabal-version: >=1.10 + +Library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Language.Melody.Syntax, + Language.Melody.Parser, + Language.Melody.Interpret, + Language.Melody.API, + Language.Melody.Interpret.Env, + Language.Melody.Interpret.Pop, + Language.Melody.Interpret.Types, + Language.Melody.Interpret.Compile, + Language.Melody.Interpret.Env.Primops + Language.Melody + build-depends: base >=4.6 && <4.7, + lens > 3.8, + mtl == 2.*, + containers == 0.5.*, + parsec == 3.*, + either > 2.9, + ParsecTools + default-language: Haskell2010 + +executable imelody + main-is: Main.hs + hs-source-dirs: repl + ghc-options: -Wall + build-depends: base >=4.6 && <4.7, melody + default-language: Haskell2010 + + +Test-Suite test-melody + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base >=4.6 && <4.7, + test-framework, + test-framework-hunit, + containers, + mtl, + HUnit, + melody diff --git a/repl/Main.hs b/repl/Main.hs new file mode 100644 --- /dev/null +++ b/repl/Main.hs @@ -0,0 +1,5 @@ +module Main where +import qualified Language.Melody as M + +main :: IO () +main = M.main diff --git a/src/Language/Melody.hs b/src/Language/Melody.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody.hs @@ -0,0 +1,28 @@ +module Language.Melody where +import Language.Melody.Parser +import Language.Melody.Interpret +import Control.Monad +import Control.Monad.Error +import System.Environment +import System.IO + +repl :: Melody +repl = forever . flip catchError (liftIO . print) $ do + liftIO $ putStr ">>> " >> hFlush stdout + l <- parseMelody `fmap` liftIO getLine + case l of + Left err -> liftIO $ print err + Right m -> eval m + +evalFile :: String -> Melody +evalFile f = do + res <- liftIO $ parseSrcFile f + case res of + Left err -> liftIO $ print err + Right toplevels -> mapM_ eval toplevels + +main :: IO () +main = do + args <- getArgs + void . runMelody $ mapM_ evalFile args >> repl + diff --git a/src/Language/Melody/API.hs b/src/Language/Melody/API.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/API.hs @@ -0,0 +1,32 @@ +module Language.Melody.API (runExpr, runTopLevel, runFile) where +import Text.Parsec +import Language.Melody.Interpret.Types +import Language.Melody.Interpret +import Language.Melody.Parser +import Language.Melody.Syntax +import Control.Monad.Trans.Either + +data Error = Parser ParseError | Eval EvalError + deriving (Show) + +type Stack = [Expr Compiled] + +type MelodyResult = IO (Either Error Stack) + +liftError :: (e -> Error) -> Either e a -> Either Error a +liftError f = either (Left . f) Right + +run :: [TopLevel] -> MelodyResult +run = fmap (liftError Eval) . runMelody . mapM_ eval + +liftParser :: (String -> Either ParseError a) -> String -> EitherT Error IO a +liftParser p = hoistEither . liftError Parser . p + +liftIOParser :: (String -> IO (Either ParseError a)) -> String -> EitherT Error IO a +liftIOParser p = EitherT . fmap (liftError Parser) . p + +runExpr, runTopLevel, runFile :: String -> MelodyResult +runExpr s = runEitherT $ liftParser parseMelodyExpr s >>= EitherT . run . (:[]) . Exec +runTopLevel t = runEitherT $ liftParser parseMelody t >>= EitherT . run . (:[]) +runFile f = runEitherT $ liftIOParser parseSrcFile f >>= EitherT . run + diff --git a/src/Language/Melody/Interpret.hs b/src/Language/Melody/Interpret.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TupleSections #-} +module Language.Melody.Interpret (eval, runMelody, Melody) where +import Control.Lens +import Data.List (nub) +import Control.Monad.Error +import Language.Melody.Interpret.Env +import Language.Melody.Interpret.Types +import Language.Melody.Interpret.Compile +import Language.Melody.Interpret.Pop +import Language.Melody.Syntax +import Control.Monad.Reader +import qualified Data.Map as M + +-- | Generate constructors for a given type. This creates +-- a new word for each constructor +generateConstrs :: TypeName -> [(Constructor, Int)] -> [(String, Melody)] +generateConstrs t = map makeConstr + where makeConstr (name, arity) = (name, replicateM arity pop >>= push . Boxed t name) + +-- | Run a given expression in an environment with no local variables +emptyEnv :: Melody -> Melody +emptyEnv = local (const M.empty) + +-- | Evaluate a @TopLevel@. If it is an expression it runs it, +-- otherwise it generates the appropriate bindings for definitions. +eval :: TopLevel -> Melody +eval (Def nm expr) = env.at nm .= Just (emptyEnv $ compile expr) +eval (Exec expr) = compile expr +eval (Type t cs) = assertUnique (map fst cs) >> env %= M.union (M.fromList $ generateConstrs t cs) + where assertUnique names = when (length names /= length (nub names)) + . throwError . Misc $ "Constructors are not unique for " ++ t +eval (MultiDef t) = multi.at t .= Just [] +eval (MultiExt t args body) = multi.at t._Just %= (:) (args, emptyEnv $ compile body) + +-- | Turn a @Melody@ expression into an @IO@ expression +runMelody :: Melody -> IO (Either EvalError [Expr Compiled]) +runMelody = getStack $ unwrapMelody (M.fromList []) defaultEnv + where getStack = mapped.mapped._Right %~ view stack diff --git a/src/Language/Melody/Interpret/Compile.hs b/src/Language/Melody/Interpret/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret/Compile.hs @@ -0,0 +1,74 @@ +module Language.Melody.Interpret.Compile (compile) where +import Language.Melody.Syntax +import Language.Melody.Interpret.Types +import Language.Melody.Interpret.Pop +import Control.Monad.Error +import Control.Monad.Reader +import Control.Lens +import Control.Applicative +import qualified Data.Map as M +import Data.Maybe + + +resolve :: [([TypeName], Melody)] -> MelodyM (Maybe Melody) +resolve cs = fmap snd . foldr choose Nothing <$> filterM matches cs + where matches (ts, _) = do + s <- map typeName <$> use stack + return $ length s >= length ts && s <<: ts + choose (t1, body1) (Just (t2, body2)) | t1 <<: t2 = Just (t1, body1) + | t2 <<: t1 = Just (t2, body2) + | otherwise = Nothing + choose t Nothing = Just t + t1 <<: t2 = all (uncurry (<:)) $ zip t1 t2 + +-- | Bind a list of expressions into a closure +addClosure :: Expr NotCompiled -> MelodyM (Expr NotCompiled) +addClosure body = (Func body . Just) <$> ask + +-- | Ask whether a word is in a closure, inlining it +-- if it is. +inlineClosedWord :: String -> MelodyM (Expr NotCompiled) +inlineClosedWord w = maybe (Word w) id . M.lookup w <$> ask + +-- | Attach a closure to a function without +-- and inline a closed word running and recurses on all +-- other compound structures +close :: Expr NotCompiled -> MelodyM (Expr NotCompiled) +close (Func body Nothing) = addClosure body +close (Word w) = inlineClosedWord w +close (Dictionary d) = Dictionary <$> mapM (both close) d +close (List l) = List <$> mapM close l +close a = return a + +-- | Resolve a variable name in the current scope +selectVariable :: String -> Melody +selectVariable w = do + global <- use (env.at w) -- Global + mult <- use (multi.at w) >>= resolving + loc <- M.lookup w <$> ask -- Local + assertExists $ pushing loc <|> mult <|> global + where pushing = fmap push + resolving = maybe (return Nothing) id . fmap resolve + assertExists = fromMaybe . lift . throwError $ NoSuchName w + +-- | Compile a group of expressions in order +compileMany :: [Expr NotCompiled] -> Melody +compileMany = mapM_ compile + +-- | Bind the list of names to the top items on the stack +addEnv :: [String] -> Melody -> Melody +addEnv names m = do + vals <- topN (length names) + local (M.union . M.fromList $ zip names vals) m + +-- | Compile a Melody expression. +-- If the expression is a word, than it is evaluated in the +-- current context, otherwise it is pushed on to the stack +compile :: Expr NotCompiled -> Melody +compile (Word w) = selectVariable w +compile (Binding nms exprs) = addEnv nms $ compileMany exprs +compile (Comp es) = compileMany es +compile (Func body Nothing) = addClosure body >>= push +compile (List es) = mapM close es >>= push . List +compile (Dictionary es) = mapM (both close) es >>= push . Dictionary +compile e = push e diff --git a/src/Language/Melody/Interpret/Env.hs b/src/Language/Melody/Interpret/Env.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret/Env.hs @@ -0,0 +1,6 @@ +module Language.Melody.Interpret.Env where +import Language.Melody.Interpret.Types +import Language.Melody.Interpret.Env.Primops + +defaultEnv :: MelodyState +defaultEnv = primops diff --git a/src/Language/Melody/Interpret/Env/Primops.hs b/src/Language/Melody/Interpret/Env/Primops.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret/Env/Primops.hs @@ -0,0 +1,79 @@ +module Language.Melody.Interpret.Env.Primops where +import Language.Melody.Syntax +import Language.Melody.Interpret.Types +import Language.Melody.Interpret.Pop +import Language.Melody.Interpret.Compile +import Control.Monad.Reader +import Control.Applicative +import Control.Lens hiding (cons, uncons) +import qualified Data.Map as M + +primops :: MelodyState +primops = MS builtins M.empty [] + +arith :: (Double -> Double -> Double) -> Melody +arith f = liftM2 f popNum popNum >>= push . NumLit + +cons :: Melody +cons = do + t <- pop + case t of + StrLit s -> pushWith popStr $ StrLit . (++ s) + List l -> pushWith pop $ List . (:l) + Dictionary d -> pushWith (pop >>= toPair) $ Dictionary . (:d) + _ -> typeError "cons: Not sequence" + where toPair (List [a, b]) = return (a, b) + toPair _ = typeError "cons: Not a list of two elements" + pushWith f with = f >>= push . with + +uncons :: Melody +uncons = do + expr <- pop + case expr of + StrLit (s : ss) -> pushBoth (StrLit [s]) (StrLit ss) + List (l : ll) -> pushBoth l (List ll) + Dictionary ((a,b): hh) -> pushBoth (List [a, b]) (Dictionary hh) + _ -> typeError "Not sequence" + where pushBoth a b = push b >> push a + +apply :: Melody +apply = do + (body, clos) <- popFunc + clos' <- maybe (fail "$: Caught non-closed lambda") return clos + void . local (M.union clos') $ compile body + -- Use the closure attached to a function + +equals :: Melody +equals = do + l <- pop + r <- pop + when (isOpaque l || isOpaque r) $ + typeError "Comparing Opaques" + if l == r then true else false + where true = void pop + false = pop <* pop >>= push + isOpaque (Opaque {}) = True + isOpaque _ = False + + +unbox :: Melody +unbox = popBoxed >>= mapM_ push . reverse . contents + where contents (_, _, es) = es + +builtins :: M.Map String Melody +builtins = M.fromList + [("pop", void pop), + ("print", pop >>= liftIO . print), + ("putStr", popStr >>= liftIO . putStrLn), + ("+", arith (+)), + ("-", arith (-)), + ("/", arith (/)), + ("*", arith (*)), + ("dump", use stack >>= liftIO . print), + ("cons", cons), + ("uncons", uncons), + ("$", apply), + ("no-op", return ()), + ("=", equals), + ("unbox", unbox), + ("typeOf", pop >>= push . StrLit . typeName)] diff --git a/src/Language/Melody/Interpret/Pop.hs b/src/Language/Melody/Interpret/Pop.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret/Pop.hs @@ -0,0 +1,82 @@ +module Language.Melody.Interpret.Pop ( + push, + pop, + topN, + popWord, + popFunc, + popDict, + popList, + popNum, + popStr, + popBoxed) where +import Language.Melody.Interpret.Types +import Language.Melody.Syntax +import Control.Monad.Error +import Control.Lens + +errorMsg :: String -> Expr Compiled -> MelodyM a +errorMsg s e = throwError . TypeMismatch $ "Expected " ++ s ++ " got " ++ show e + +push :: Expr NotCompiled -> Melody +push = (stack %=) . (:) + +pop :: MelodyM (Expr Compiled) +pop = do + h <- use (stack.to headMay) + case h of + Just x -> stack %= tail >> return x + Nothing -> lift . throwError $ UnderflowError "Somewhere" + where headMay [] = Nothing + headMay (c:_) = Just c + +popWord :: MelodyM String +popWord = do + h <- pop + case h of + Word w -> return w + e -> errorMsg "word" e + +popFunc :: MelodyM (Expr NotCompiled, Maybe Closure) +popFunc = do + f <- pop + case f of + Func exprs clos -> return (exprs, clos) + e -> errorMsg "func" e + +popDict :: MelodyM [(Expr Compiled, Expr Compiled)] +popDict = do + h <- pop + case h of + Dictionary d -> return d + e -> errorMsg "hash" e + +popList :: MelodyM [Expr Compiled] +popList = do + h <- pop + case h of + List w -> return w + e -> errorMsg "list" e + +popNum :: MelodyM Double +popNum = do + h <- pop + case h of + NumLit n -> return n + e -> errorMsg "num" e + +popStr :: MelodyM String +popStr = do + h <- pop + case h of + StrLit n -> return n + e -> errorMsg "str" e + +popBoxed :: MelodyM (String, String, [Expr Compiled]) +popBoxed = do + b <- pop + case b of + Boxed t c es -> return (t, c, es) + e -> errorMsg "boxed" e + +topN :: Int -> MelodyM [Expr Compiled] +topN = flip replicateM pop diff --git a/src/Language/Melody/Interpret/Types.hs b/src/Language/Melody/Interpret/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Interpret/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Melody.Interpret.Types where +import Language.Melody.Syntax +import Control.Monad.Error +import Control.Monad.State +import Control.Monad.Reader +import Control.Lens +import Data.Monoid +import Data.Map(Map, empty, union) + +data EvalError = UnderflowError String + | TypeMismatch String + | NoSuchName String + | Misc String + deriving (Eq, Show) + +instance Error EvalError where + strMsg = Misc + noMsg = Misc "Report this error" + + + +type MelodyM = ReaderT Closure (StateT MelodyState (ErrorT EvalError IO)) +-- Since melody is stack based, there's no need for return values +type Melody = MelodyM () + +data MelodyState = MS { _env :: Map String Melody + , _multi :: Map String [([TypeName], Melody)] + , _stack :: [Expr Compiled]} + +makeLenses ''MelodyState + +instance Monoid MelodyState where + mempty = MS empty empty [] + mappend (MS env1 multi1 stack1) (MS env2 multi2 stack2) = MS (union env1 env2) + (union multi1 multi2) + (stack1 ++ stack2) + +unwrapMelody :: Closure -> MelodyState -> Melody -> IO (Either EvalError MelodyState) +unwrapMelody lexVars defaultEnv = + runErrorT . flip execStateT defaultEnv . flip runReaderT lexVars + +typeError :: String -> MelodyM a +typeError = throwError . TypeMismatch diff --git a/src/Language/Melody/Parser.hs b/src/Language/Melody/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Parser.hs @@ -0,0 +1,110 @@ +module Language.Melody.Parser (parseMelody, parseMelodyExpr, parseSrcFile) where +import Language.Melody.Syntax +import Text.Parsec +import Text.Parsec.Numbers +import Text.Parsec.String +import Control.Applicative hiding ((<|>), many) +import Control.Monad (void) + +parseId :: Parser String +parseId = many1 . oneOf $ "!@#$&*_-+=<>" ++ ['a'..'z'] ++ ['A' .. 'Z'] + +parseWord :: Parser (Expr NotCompiled) +parseWord = Word <$> parseId + +parseQuotedWord :: Parser (Expr NotCompiled) +parseQuotedWord = noClosFunc <$> (char '\'' *> parseWord) + +parseFunc :: Parser (Expr NotCompiled) +parseFunc = noClosFunc <$> + (char '[' *> spaces *> parseExpr <* spaces <* char ']') + +parseList :: Parser (Expr NotCompiled) +parseList = do + char '(' *> spaces + exprs <- parseExpr `sepBy` (spaces >> char ';' >> spaces) + void $ spaces *> char ')' + return $ List exprs + +parseDict :: Parser (Expr NotCompiled) +parseDict = do + char '(' *> spaces + exprs <- ((,) <$> parseExpr <*> (sep >> parseExpr)) + `sepBy` (spaces >> char ';' >> spaces) + void $ spaces >> char ')' + return $ Dictionary exprs + where sep = spaces >> string "~>" >> spaces + +parseNum :: Parser (Expr NotCompiled) +parseNum = NumLit <$> parseFloat + +parseStr :: Parser (Expr NotCompiled) +parseStr = StrLit <$> (char '"' *> many (noneOf "\"") <* char '"') + +parseBinding :: Parser (Expr NotCompiled) +parseBinding = do + char '{' >> spaces + nms <- parseId `sepBy` spaces + spaces >> char ',' >> spaces + exprs <- parseExpr `sepBy` spaces + void $ spaces >> char '}' + return $ Binding nms exprs + +parseExpr :: Parser (Expr NotCompiled) +parseExpr = do + e <- p + es <- try (p `sepBy1` spaces) <|> return [] + return $ if null es then e else Comp (e:es) + where p = spaces *> + (parseWord + <|> parseQuotedWord + <|> parseFunc + <|> try parseList -- Backtracking for dictionaries + <|> parseDict + <|> parseNum + <|> parseStr + <|> parseBinding) + +parseDef :: Parser TopLevel +parseDef = do + char ':' *> spaces + Word n <- parseWord + Def n <$> parseExpr + +parseType :: Parser TopLevel +parseType = do + string "type" *> spaces + name <- parseId <* spaces + char '=' *> spaces + cs <- constr `sepBy1` (spaces *> char '|' *> spaces) + return $ Type name cs + where constr = (,) <$> parseId <*> (spaces *> parseIntegral) + +parseMultiDef :: Parser TopLevel +parseMultiDef = do + string "def" *> spaces + MultiDef <$> parseId <* spaces + +parseMultiExt :: Parser TopLevel +parseMultiExt = do + string "ext" *> spaces + MultiExt <$> (parseId <* spaces) <*> types <*> parseExpr + where types = char '[' *> parseId `sepBy` (spaces *> char ';' <* spaces) <* char ']' + +parseTopLevel :: Parser TopLevel +parseTopLevel = spaces *> + (try parseType + <|> try parseMultiDef + <|> try parseMultiExt + <|> parseDef + <|> Exec <$> parseExpr) + <* spaces <* char '.' <* spaces + +parseMelody :: String -> Either ParseError TopLevel +parseMelody = parse parseTopLevel "Melody Parser" + +parseMelodyExpr :: String -> Either ParseError (Expr NotCompiled) +parseMelodyExpr = parse parseExpr "Melody Parser" + +parseSrcFile :: String -> IO (Either ParseError [TopLevel]) +parseSrcFile = parseFromFile (many1 parseTopLevel) diff --git a/src/Language/Melody/Syntax.hs b/src/Language/Melody/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Melody/Syntax.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE EmptyDataDecls #-} +module Language.Melody.Syntax where +import Data.List +import Data.Dynamic (Dynamic) +import Data.Map (Map) + +type Closure = Map String (Expr Compiled) + +-- | The AST representing Melody's expressions +data MExpr = Word String + -- ^ The most basic type, represents a variable + | Func MExpr (Maybe Closure) + -- ^ An anonymous function, consisting of the expression it contaisn + -- that it evaluates and the closure it was created in. + | Dictionary [(MExpr, MExpr)] + -- ^ An associative map type + | List [MExpr] + -- ^ A list type + | NumLit Double + -- ^ The only type of numeric literal, a @Double@ + | StrLit String + -- ^ The wrapped string representing strings in melody code + | Binding [String] [MExpr] + -- ^ A binding expressions binding the list of strings + -- to values on the stack as variables in the list of expressions. + | Comp [MExpr] + -- ^ Represents the composition of several expressions + | Boxed TypeName Constructor [MExpr] + -- ^ The representation of product types, consists of a type tag and fields + | Opaque String Dynamic + -- ^ An opaque type, such as a filehandle. + -- It's boxed in dynamic and paired with a description. + +instance Eq MExpr where + (Word w1) == (Word w2) = w1 == w2 + (Func b1 c1) == (Func b2 c2) = b1 == b2 && c1 == c2 + (Dictionary d1) == (Dictionary d2) = d1 == d2 + (List l1) == (List l2) = l1 == l2 + (NumLit d1) == (NumLit d2) = d1 == d2 + (StrLit s1) == (StrLit s2) = s1 == s2 + (Binding nms1 exprs1) == (Binding nms2 exprs2) = nms1 == nms2 && exprs1 == exprs2 + (Comp es1) == (Comp es2) = es1 == es2 + (Boxed t1 c1 e1) == (Boxed t2 c2 e2) = t1 == t2 && c1 == c2 && e1 == e2 + _ == _ = False + +data Compiled -- ^ Has been evaluated, contains no free variables +data NotCompiled -- ^ Raw and unevaluated + +-- | A phantom type to represent whether data has been +-- evaluated. +type Expr a = MExpr + +instance Show MExpr where + show (Word w) = w + show (Func ws _) = "[" ++ show ws ++ "]" + show (Dictionary d) = "(" ++ concatMap showPair d ++ ")" + where showPair (k, v) = show k ++ " ~> " ++ show v ++ ", " + show (List ls) = "(" ++ intercalate " ; " (map show ls) ++ ")" + show (NumLit n) = show n + show (StrLit s) = show s + show (Binding nms exprs) = + "{" ++ unwords nms ++ "," ++ unwords (map show exprs) ++ "}" + show (Comp exprs) = unwords . map show $ exprs + show (Boxed t c vs) = t ++ '.' : c ++ "(" ++ unwords (map show vs) ++ ")" + show (Opaque desc _) = desc + +type Constructor = String +type TypeName = String +-- | The AST for toplevel forms in Melody programs +data TopLevel = Def String (Expr NotCompiled) + -- ^ A word definition, dynamically binds + -- the string to the list of expressions + | Exec (Expr NotCompiled) + -- ^ Executes the list of expressions + | Type TypeName [(Constructor, Int)] + -- ^ A variant type, associates a typename + -- @String@ with a list of constructors. + | MultiDef String + | MultiExt String [TypeName] (Expr NotCompiled) + deriving(Eq, Show) + +-- | Generate a function with an empty closure. +-- Avoids importing @Data.Map@ everywhere. +noClosFunc :: Expr NotCompiled -> Expr NotCompiled +noClosFunc = flip Func Nothing + +typeName :: MExpr -> TypeName +typeName (NumLit {}) = "Num" +typeName (StrLit {}) = "Str" +typeName (Word {}) = "Word" +typeName (Binding {}) = "Binding" +typeName (Boxed t _ _) = t +typeName (List {}) = "List" +typeName (Dictionary {}) = "Dictionary" +typeName (Func {}) = "Func" +typeName (Opaque s _) = s +typeName (Comp {}) = "Comp" + +(<:) :: TypeName -> TypeName -> Bool +_ <: "_" = True +a <: b = a == b diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,6 @@ +import Data.Monoid +import Utils +import Eq + +main :: IO () +main = defaultMainWithOpts [equalityTests] mempty