git.haldean.org del / 30e5126 src / Language / Del / CompileDefs.hs
30e5126

Tree @30e5126 (Download .tar.gz)

CompileDefs.hs @30e5126raw · history · blame

module Language.Del.CompileDefs where

import qualified Data.Text as T
import           Language.Del.AST
import           Language.Del.TypeTable
import qualified Text.Parsec.Error as PErr

data Error
    = SystemError T.Text
    | ReadError PErr.ParseError
    | MissingRootError
    | RecursionError T.Text
    | BadArity T.Text Int Int -- name of function, expected arity, source arity
    | BadTypeName T.Text
    | BadRootType Type
    | ReturnTypeMismatch T.Text Type Type -- name of function, expected type,
                                          -- type in source
    | BadId T.Text
    | Unsubscriptable Type T.Text
    | BadSubscript Type T.Text [T.Text]
    | BadApplyHead Expr Type
    | BadArgType T.Text Type Type Int Expr
    | BadIfCondition Type Expr
    | IfTypeMismatch Type Type Expr
    | BadNativeName Expr Expr -- expr that's supposed to be the native func
                              -- name, full native call expr
    | ApplyHeadNotId Expr
    deriving (Eq)

data Artifact a
    = Success a
    | Failure Error
    deriving (Show, Eq)

instance Functor Artifact where
    fmap f x = x >>= return . f

instance Applicative Artifact where
    pure = Success
    Success f <*> Success x = Success (f x)
    Success _ <*> Failure e = Failure e
    Failure e <*> _ = Failure e

instance Monad Artifact where
    (Success x) >>= f = f x
    (Failure e) >>= _ = Failure e
    fail msg = Failure $ SystemError $ T.pack msg

instance Show Error where
    show (SystemError t) = "unexpected system error: " ++ T.unpack t
    show (ReadError p) = "syntax error: " ++ show p
    show MissingRootError =
        "root function not defined. You must (define root) to create an entry point"
    show (RecursionError func) =
        "recursive functions are not supported, but " ++ T.unpack func ++ " is recursive"
    show (BadArity func expect src) =
        "function \"" ++ T.unpack func ++ "\" takes " ++ show expect ++ " arguments, but " ++
        show src ++ " were given"
    show (BadTypeName tn) = "unknown type name \"" ++ T.unpack tn ++ "\""
    show (BadRootType t) =
        "root function must return a color, provided root has return type " ++ show t
    show (ReturnTypeMismatch n e a) =
        "function " ++ T.unpack n ++ " defined to have type " ++ show e ++ ", but body has type " ++ show a
    show (BadId n) = "unknown name " ++ T.unpack n
    show (Unsubscriptable t sub) =
        "tried to take subscript " ++ T.unpack sub ++ " of un-subscript-able type " ++ show t
    show (BadSubscript t sub allow) =
        "tried to take invalid subscript " ++ T.unpack sub ++ " of type " ++ show t ++ ", valid subscripts are " ++ show allow
    show (BadApplyHead hd t) =
        "tried to call function " ++ show hd ++ " which has non-function-type " ++ show t
    show (BadArgType n ex ac i e) =
        "argument " ++ show i ++ " to " ++ T.unpack n ++ " was type " ++ show ac ++
        ", expected type " ++ show ex ++ ", in expression:\n\n\t" ++ show e ++ "\n"
    show (BadIfCondition t e) =
        "condition in if statement has type " ++ show t ++ ", should be boolean, in expression:\n\n\t" ++ show e ++ "\n"
    show (IfTypeMismatch tt tf e) =
        "branches in if statement have different types; true branch is " ++ show tt ++
        ", false branch is " ++ show tf ++ " in expression:\n\n\t" ++ show e ++ "\n"
    show (BadNativeName n e) =
        "first argument to $ must be a function name, got " ++ show n ++
        " in expression:\n\n\t" ++ show e ++ "\n"
    show (ApplyHeadNotId e) =
        "head of list must be the name of a function in expression:\n\n\t" ++
        show e ++ "\n"