feat: error handling

 - Created `Error` type for describing errors.
 - Maybe changed to Either

HLasm.cabal

@@ -1,10 +1,8 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.1.
+-- This file has been generated from package.yaml by hpack version 0.34.1.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: 6cca8ef12b48d6c2337ca3596a778423af51d8f48437da9bec4a4e2770142e12
 
 name:           HLasm
 version:        0.1.0.0
@@ -28,6 +26,7 @@ library
   exposed-modules:
       HLasm.Ast
       HLasm.Backend.Nasm
+      HLasm.Error
       HLasm.Frame
       HLasm.Instructions
       HLasm.Parser

app/Main.hs

@@ -4,6 +4,7 @@ module Main where
 
 import           System.Environment (getArgs)
 import           Control.Monad.Zip
+import           Data.Bifunctor (first)
 
 import           Funcs
 import           HLasm.Parser
@@ -14,16 +15,16 @@ import           HLasm.Instructions (instructions, BackEnd(..), runBackend)
 import           HLasm.Backend.Nasm
 
 parseAll :: String -> String
-parseAll = get . pipeline
+parseAll = get . first show . pipeline
     where pipeline src = 
-            do parsed    <- parse src
-               semantic  <- err "Scope error" semantic parsed
-               _         <- err "Type error"  typeCheck semantic
-               stack     <- Right $ (buildStackFrames Root) parsed
-               tree <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack 
-               instructions <- err "Assembly error" instructions tree
-               Right . runBackend nasm $ instructions
-               
+            do parsed   <- parse src
+               semantic <- semantic parsed
+               _        <- typeCheck semantic
+               stack    <- Right $ (buildStackFrames Root) parsed
+               tree     <- Right $ mzipWith (\(e, v, l) (_, sf) -> (e, v, l, sf)) semantic stack 
+               instructions <- instructions tree
+               runBackend nasm instructions
+
 main :: IO ()
 main = do
     args <- getArgs

src/HLasm/Ast.hs

@@ -33,7 +33,12 @@ data HLValue =
     NameValue VariableName
     | IntegerValue Int
     | StringValue String
-    deriving (Show, Eq)
+    deriving (Eq)
+
+instance Show HLValue where
+    show (NameValue   name) = name
+    show (IntegerValue num) = show num
+    show (StringValue  str) = show str
 
 data Condition = Condition (HLValue, CompareType, HLValue)
     deriving (Show, Eq)

src/HLasm/Backend/Nasm.hs

@@ -55,4 +55,4 @@ join s [x]    = x
 join s (x:xs) = x ++ s ++ join s xs
 
 nasm :: BackEnd
-nasm = BackEnd (\x -> join "\n" . concat $ fmap instruction x)
+nasm = BackEnd (\x -> Right . join "\n" . concat $ fmap instruction x)

src/HLasm/Error.hs

@@ -0,0 +1,24 @@
+-- Copyright (c) 2020 Vorotynsky Maxim
+
+module HLasm.Error where
+
+import HLasm.Ast
+import qualified Text.Parsec
+
+data Error = 
+    StringError String
+    | ParseError Text.Parsec.ParseError
+    | VariableNotFound VariableName
+    | LabelNotFound Label
+    | IncompatibleTypes (HLValue, HLValue)
+    deriving (Eq)
+
+type Result a = Either Error a
+
+instance Show Error where
+    show (StringError msg) = "error: " ++ msg ++ ".\n"
+    show (VariableNotFound name) = "scope error: variable \'" ++ name ++ "\' not found.\n"
+    show (LabelNotFound label) = "scope error: label \'" ++ label ++ "\' not found.\n"
+    show (IncompatibleTypes (left, right)) = 
+        "type error: incompatible types between \'" ++ show left ++ "\' and \'" ++ show right ++ "\'.\n"
+    show (ParseError err) = "parser error, " ++ show err

src/HLasm/Instructions.hs

@@ -15,6 +15,7 @@ import           Data.Tree
 import           HLasm.Ast
 import           HLasm.Frame
 import           HLasm.Scope
+import           HLasm.Error
 
 type Offset = Int
 type Size = Int
@@ -39,52 +40,52 @@ data Instructions =
 
 type InstructionSet = [Instructions]
 
-newtype BackEnd = BackEnd (InstructionSet -> String)
+newtype BackEnd = BackEnd (InstructionSet -> Result String)
 runBackend (BackEnd f) x = f x
 
+
 target :: StackFrame -> VariableData -> Target
 target _ (VariableData (_, VariableDeclaration (HLasm.Ast.Register(_, reg)))) = HLasm.Instructions.Register reg
 target frame (VariableData (name, e)) = case findOffset frame name of
     Just x  -> FrameVar (x, size e, name)
     Nothing -> NamedTarget name
     where size (VariableDeclaration v) = valueSize v
 
-findTarget :: StackFrame -> [VariableData] -> VariableName -> Target
+findTarget :: StackFrame -> [VariableData] -> VariableName -> Target --  was a lot of checks, target garanteed be here.
 findTarget frame xs name = target frame . fromJust . find (\(VariableData (n, _)) -> n == name) $ xs
 
 valuableTarget :: (StackFrame, [VariableData]) -> HLValue -> Target
-valuableTarget _ (IntegerValue v)        = ConstantTarget v
+valuableTarget _        (IntegerValue v) = ConstantTarget v
 valuableTarget (sf, vd) (NameValue name) = findTarget sf vd name
 
-loop :: Label -> Maybe (InstructionSet) -> Maybe (InstructionSet)
+loop :: Label -> Result (InstructionSet) -> Result (InstructionSet)
 loop lbl i = let begin = lbl ++ "begin" in fmap (\x -> [Label begin] ++ x ++ [Jump begin Nothing, Label (lbl ++ "end")]) $ i
 
-instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Maybe (InstructionSet)
+instructions :: Tree (HLElement, [VariableData], [LabelData], StackFrame) -> Result (InstructionSet)
 instructions (Node ((InstructionSet         ), _, _, _) xs) = concatMapM instructions xs
-instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Just []
+instructions (Node ((VariableDeclaration val), _, _, _) _ ) = Right []
 instructions (Node ((While lbl              ), _, _, _) xs) = loop lbl (concatMapM instructions xs)
 instructions (Node ((DoWhile lbl            ), _, _, _) xs) = loop lbl (concatMapM instructions xs)
-instructions (Node ((Break lbl              ), _, _, _) _ ) = Just [Jump (lbl ++ "end") Nothing]
-instructions (Node ((HLasm.Ast.Call lbl ns  ), d, _, f) _ ) = 
-    Just [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size]
-    where size = foldl (+) 0 . fmap (\(VariableData (_, (VariableDeclaration d))) -> valueSize d) $ d 
-instructions (Node ((AssemblyCall str       ), _, _, _) _ ) = Just [PureAsm str]
+instructions (Node ((Break lbl              ), _, _, _) _ ) = Right [Jump (lbl ++ "end") Nothing]
+instructions (Node ((AssemblyCall str       ), _, _, _) _ ) = Right [PureAsm str]
 instructions (Node ((Frame lbl              ), _, _, f) xs) =
-    fmap (\x -> [BeginFrame f lbl] ++ x ++ [EndFrame f lbl]) $ concatMapM instructions xs
+    (\body -> [BeginFrame f lbl] ++ body ++ [EndFrame f lbl]) <$> concatMapM instructions xs
 
-instructions (Node ((Assignment name (NameValue val)),    d, _, f) _) = Just [Move (findTarget f d name) (findTarget f d val)]
-instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Just [Move (findTarget f d name) (ConstantTarget val)]
+instructions (Node ((Assignment name (NameValue val)),    d, _, f) _) = Right [Move (findTarget f d name) (findTarget f d val)]
+instructions (Node ((Assignment name (IntegerValue val)), d, _, f) _) = Right [Move (findTarget f d name) (ConstantTarget val)]
 
-instructions (Node ((If lbl), _, _, _) []) = Just []
+instructions (Node ((HLasm.Ast.Call lbl ns  ), d, _, f) _ ) = 
+    Right [HLasm.Instructions.Call lbl (fmap (findTarget f d) ns) size]
+    where size = foldl (+) 0 . fmap (\(VariableData (_, (VariableDeclaration d))) -> valueSize d) $ d 
+
+instructions (Node ((If lbl), _, _, _) []) = Right []
 instructions (Node ((If lbl), _, _, _) xs) =
-    let (conds, bodies') = traverse (uncurry branch) (zip [1..] xs);
-        bodies = fmap (concat) . sequence $ bodies'
-     in fmap (\b -> conds ++ b ++ [Label (lbl ++ "end")]) bodies
-    where condition pt lbl (Condition (left, cmp, right)) =
-              [Compare (valuableTarget pt left) (valuableTarget pt right), Jump lbl (Just cmp)]
-          wrapif lbl i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing])
-          branch i (Node ((IfBranch (Just cond)), d, _, f) xs)  =
-              (condition (f, d) (lbl ++ show i) cond, wrapif lbl i (concatMapM instructions xs))
-          branch i (Node ((IfBranch Nothing),     _, _, _) xs)  =
-              ([Jump (lbl ++ show i) Nothing], wrapif lbl i (concatMapM instructions xs))
-          a = traverse (uncurry branch) (zip [1..] xs)
+    do (conds, bodies') <- Right $ traverse (uncurry branch) (zip [1..] xs)
+       bodies           <- fmap (concat) . sequence $ bodies'
+       Right $ conds ++ bodies ++ [Label (lbl ++ "end")]
+
+    where condition lbl pt (Condition (left, cmp, right)) =
+              let find = valuableTarget pt in [Compare (find left) (find right), Jump lbl (Just cmp)]
+          wrapif i = fmap (\b -> [Label (lbl ++ show i)] ++ b ++ [Jump (lbl ++ "end") Nothing]) . concatMapM instructions
+          branch i (Node ((IfBranch (Just cond)), d, _, f) xs) = (condition (lbl ++ show i) (f, d) cond, wrapif i xs)
+          branch i (Node ((IfBranch Nothing),     _, _, _) xs) = ([Jump     (lbl ++ show i)    Nothing], wrapif i xs)

src/HLasm/Parser.hs

@@ -5,6 +5,7 @@
 module HLasm.Parser (HLasm.Parser.parse) where
 
 import           HLasm.Ast
+import           HLasm.Error
 
 import           Data.Bifunctor     (first)
 import           Data.Maybe         (maybeToList)
@@ -85,5 +86,5 @@ hlasm = reduce [ asmCall,             call,           HLasm.Parser.break,
                  assignment ]
     where reduce (x:xs) = foldl (<|>) x xs
 
-parse :: String -> Either String SyntaxTree
-parse = first show . Text.Parsec.parse hlasm ""
+parse :: String -> Result SyntaxTree
+parse = first ParseError . Text.Parsec.parse hlasm ""

src/HLasm/Scope.hs

@@ -13,7 +13,9 @@ module HLasm.Scope
 
 import           Control.Monad.Zip
 import           Data.Tree
+import           Data.Bifunctor
 import           HLasm.Ast
+import           HLasm.Error
 
 data ScopeData = FluentScope
     | IntroduceVariable HLValuable
@@ -67,24 +69,24 @@ fromScopeData s (Node (el, sd) xs) = Node (el, currScope) (fmap (fromScopeData c
 newtype VariableData = VariableData (VariableName, HLElement) deriving (Show)
 newtype LabelData    = LabelData    (Label,        HLElement) deriving (Show)
 
-findVar :: Scope -> VariableName -> Maybe VariableData
-findVar Root _ = Nothing
+findVar :: Scope -> VariableName -> Either VariableName VariableData
+findVar Root name = Left name
 findVar (Scope {scopeData = (IntroduceVariable var), scopeElement = el}) name | valuableName var == name =
-    Just $ VariableData (name, el)
+    Right $ VariableData (name, el)
 findVar (Scope {scopeParent = p}) name = findVar p name
 
-findLabel :: Scope -> VariableName -> Maybe LabelData
-findLabel Root _ = Nothing
+findLabel :: Scope -> Label -> Either Label LabelData
+findLabel Root label = Left label
 findLabel (Scope {scopeData = (IntroduceLabel lbl), scopeElement = el}) label | lbl == label =
-    Just $ LabelData (lbl, el)
+    Right $ LabelData (lbl, el)
 findLabel (Scope {scopeParent = p}) label = findLabel p label
 
 type SemanticTree = Tree (HLElement, [VariableData], [LabelData])
 
-semantic :: SyntaxTree -> Maybe SemanticTree
+semantic :: SyntaxTree -> Result SemanticTree
 semantic t = traverse process . fromScopeData Root $ mzip t (fmap elementToScope t)
     where used f u s = sequence . fmap (f s) . u
           process (el, scope) = do
-              vars <- used findVar usedVariables scope el
-              labels <- used findLabel usedLabels scope el
-              Just (el, vars, labels)
+              vars   <- first VariableNotFound $ used findVar usedVariables scope el
+              labels <- first LabelNotFound    $ used findLabel usedLabels scope el
+              Right (el, vars, labels)

src/HLasm/Types.hs

@@ -4,8 +4,10 @@ module HLasm.Types where
 
 import           Data.Maybe
 import           Data.Tree
+import           Data.Bifunctor
 import           HLasm.Ast
 import           HLasm.Scope
+import           HLasm.Error
 
 typeSuit :: Type -> Type -> Bool
 typeSuit (Type lname _) (Type rname _) | (lname /= rname) = False
@@ -32,18 +34,20 @@ literalType _ (IntegerValue x) = Just $ Type "int" (Just $ size x)
 literalType s (NameValue name) = lookupType name s
 literalType _ _ = undefined
 
-astCheck :: HLElement -> [VariableData] -> Bool
-astCheck (IfBranch (Just (Condition (left, _, right)))) xs = fromMaybe False $
-    do leftType  <- literalType xs left
-       rightType <- literalType xs right
-       Just $ typeSuit leftType rightType
-astCheck (Assignment left right) xs = fromMaybe False $
-    do leftType  <- lookupType left xs
-       rightType <- literalType xs right
-       Just $ typeSuit leftType rightType
-astCheck _ _ = True
-
-typeCheck :: SemanticTree -> Maybe SemanticTree
+err a b = maybe (Left (a, b)) Right
+
+astCheck :: HLElement -> [VariableData] -> Either (HLValue, HLValue) ()
+astCheck (IfBranch (Just (Condition (left, _, right)))) xs =
+    do leftType  <- err left right $ literalType xs left
+       rightType <- err left right $ literalType xs right
+       if typeSuit leftType rightType then Right () else err left right Nothing
+astCheck (Assignment left right) xs =
+    let error = err (NameValue left) right in
+    do leftType  <- error $ lookupType left xs
+       rightType <- error $ literalType xs right
+       if typeSuit leftType rightType then Right () else error Nothing
+astCheck _ _ = Right ()
+
+typeCheck :: SemanticTree -> Either Error SemanticTree
 typeCheck tree = traverse f tree
-    where f x@(elem, vars, _) = if astCheck elem vars then Just x else Nothing
-
+    where f x@(elem, vars, _) = bimap IncompatibleTypes (const x) $ astCheck elem vars