release(v1.1): errors & backend

Author: vorotynsky

Kroha.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           Kroha
-version:        1.0.0.0
+version:        1.1.0.0
 description:    Please see the README on GitHub at <https://github.com/vorotynsky/HLasm#readme>
 homepage:       https://github.com/vorotynsky/HLasm#readme
 bug-reports:    https://github.com/vorotynsky/HLasm/issues
@@ -27,7 +27,9 @@ executable Kroha
   other-modules:
       Kroha
       Kroha.Ast
+      Kroha.Backends.Common
       Kroha.Backends.Nasm
+      Kroha.Errors
       Kroha.Instructions
       Kroha.Parser
       Kroha.Scope

package.yaml

@@ -1,5 +1,5 @@
 name:                Kroha
-version:             1.0.0.0
+version:             1.1.0.0
 github:              "vorotynsky/HLasm"
 license:             GPL-3
 author:              "Vorotynsky Maxim"

src/Kroha.hs

@@ -1,25 +1,28 @@
 module Kroha where
 
-import           Control.Monad.Zip (munzip, mzip)
-import           Data.Bifunctor    (first)
-import           Data.Tree         (Tree (..), drawTree)
+import           Control.Monad.Zip     (mzip)
+import           Data.Bifunctor        (first)
+import           Data.Tree             (Tree (..))
 
-import           Kroha.Ast         (FrameElement (..), selectorProg)
-import           Kroha.Parser      (parse)
-import           Kroha.Scope       (linkProgram, linksTree)
-import           Kroha.Stack       (stack)
-import           Kroha.Types       (resolve, typeCasts)
-import           Kroha.Instructions(instructions)
-import           Kroha.Backends.Nasm (runNasm)
+import           Kroha.Parser          (parse)
+import           Kroha.Ast             (FrameElement (Instructions), selectorProg)
+import           Kroha.Scope           (linkProgram, linksTree)
+import           Kroha.Types           (resolve, typeCastsTree, TypeConfig(..))
+import           Kroha.Stack           (stack)
+import           Kroha.Instructions    (instructions)
+import           Kroha.Backends.Common (runBackend, Backend(typeConfig))
+import           Kroha.Backends.Nasm   (nasm)
 
 
 kroha :: String -> Either String String
-kroha src = compile
+kroha src = first show compile
     where compile = do
-                    program <- first id   $ parse src
-                    scopes  <- first show $ linkProgram program
+                    program <- parse src
+                    scopes  <- linkProgram program
                     let programTree = Node (Instructions []) (selectorProg (const $ Instructions []) id program)
-                    types   <- first show $ resolve 16 . typeCasts $ mzip (linksTree program) scopes
-                    let stackRanges = stack 16 program
+                    let tc = (typeConfig nasm)
+                    casts   <- (typeCastsTree tc $ mzip (linksTree program) scopes)
+                    types   <- resolve tc casts
+                    let stackRanges = stack tc program
                     let prepared = instructions stackRanges scopes program
-                    return (runNasm prepared)
+                    return (runBackend nasm prepared)

src/Kroha/Backends/Common.hs

@@ -0,0 +1,43 @@
+module Kroha.Backends.Common (Backend(..), runBackend) where
+
+import Kroha.Ast (Declaration(..))
+import Kroha.Types (TypeConfig)
+import Kroha.Instructions (Instruction(Body), Section)
+
+import Control.Monad (join)
+import Data.Tree (Tree(..))
+import Data.Char (isSpace)
+import Data.Semigroup (Min(Min, getMin))
+
+
+data Backend = Backend 
+    { typeConfig :: TypeConfig
+    , instruction :: Instruction -> [String]
+    , bodyWrap :: [String] -> [String]
+    , indent :: String
+    , section :: Section -> String -> String
+    , declaration :: Declaration -> [String] -> String }
+
+
+makeFix :: Backend -> Tree [Instruction] -> [String]
+makeFix backend (Node i c) = join . fmap asmFix $ i
+    where asmFix (Body _ i) = fmap ((++) (indent backend)) . bodyWrap backend $ makeFix backend (c !! i)
+          asmFix i          = instruction backend i
+
+unindentManual :: String -> [String]
+unindentManual code = fmap (drop minIndent) lined
+    where lined = let (h:t) = (\l -> if null l then [""] else l) $ lines code in if null h then t else h:t
+          filterEmpty = filter (not . null . filter (not . isSpace))
+          minIndent = getMin . foldMap (Min . length . takeWhile isSpace) . filterEmpty $ lined
+
+backendDeclaration :: Backend -> Declaration -> Tree [Instruction] -> String
+backendDeclaration b decl@(Frame _ frame)          ti = declaration b decl (makeFix b ti)
+backendDeclaration b decl@(GlobalVariable   _ _ l) _  = declaration b decl []
+backendDeclaration b decl@(ConstantVariable _ _ l) _  = declaration b decl []
+backendDeclaration b decl@(ManualFrame _ c)        _  = declaration b decl (unindentManual c)
+backendDeclaration b decl@(ManualVariable _ _ c)   _  = declaration b decl (unindentManual c)
+
+runBackend :: Backend -> [(Section, Declaration, Tree [Instruction])] -> String
+runBackend backend = join . fmap (mapper)
+    where mapper (s, d, i) = section backend s (backendDeclaration backend d i)
+

src/Kroha/Backends/Nasm.hs

@@ -1,13 +1,18 @@
-module Kroha.Backends.Nasm where
+module Kroha.Backends.Nasm (nasm) where
 
 import Data.Tree
+import Data.Graph (buildG)
 import Data.List (groupBy, intercalate)
 import Control.Monad.Fix (fix)
 import Control.Monad (join)
 import Data.List.Extra (groupSort)
+import Data.Bifunctor (first)
 
 import Kroha.Ast
-import Kroha.Instructions hiding (target)
+import Kroha.Backends.Common
+import Kroha.Types
+import Kroha.Instructions (Instruction(..), LabelTarget(..), Target(..), Section)
+import Kroha.Errors
 
 bytes :: Int -> Int
 bytes x = ceiling ((toEnum x) / 8)
@@ -36,32 +41,37 @@ nasm16I (CallI l args)               = (fmap (((++) "push ") . target) . reverse
 nasm16I (Jump l Nothing)             = ["jmp " ++ label l]
 nasm16I (Jump lbl (Just (l, c, r)))  = ["cmp " ++ target l ++ ", " ++ target r, jump c ++ " " ++ label lbl]
 
-nasmBodyWrap body = body
-
-makeFix :: Tree [Instruction] -> [String]
-makeFix (Node i c) = join . fmap asmFix $ i
-    where asmFix (Body _ i) = fmap ((++) indent) . bodyWrap $ makeFix (c !! i)
-          asmFix i          = asm i
-          (asm, indent, bodyWrap) = (nasm16I, "  ", id)
-
-nasmSection :: Section -> [[String]] -> String
-nasmSection section declarations = header <> body <> "\n\n"
+nasmSection :: Section -> String -> String
+nasmSection section body = header <> body <> "\n\n"
     where header = "section ." ++ section ++ "\n"
-          body   = intercalate "\n" . fmap (intercalate "\n") $ declarations
 
 nasmType :: TypeName -> String
 nasmType (TypeName "int8" ) = "db"
 nasmType (TypeName "int16") = "dw"
 
-nasmDeclaration :: Tree [Instruction] -> Declaration -> [String]
-nasmDeclaration t (Frame l _)                               = [l ++ ":"] ++ makeFix t ++ ["leave", "ret"]
-nasmDeclaration _ (GlobalVariable   n t (IntegerLiteral l)) = [n ++ ": " ++ nasmType t ++ " " ++ show l]
-nasmDeclaration _ (ConstantVariable n t (IntegerLiteral l)) = [n ++ ": " ++ nasmType t ++ " " ++ show l]
-nasmDeclaration _ (ManualFrame l c)                         = [l ++ ":", c]
-nasmDeclaration _ (ManualVariable v _ c)                    = [v ++ ": " ++ c]
+nasmDeclaration :: Declaration -> [String] -> String
+nasmDeclaration (Frame l _)                               body  = l ++ ":\n" ++ intercalate "\n" body ++ "\nleave\nret\n"
+nasmDeclaration (ManualVariable v _ _)                   [body] = v ++ ": "  ++ body ++ "\n"
+nasmDeclaration (ManualFrame l _)                         body  = l ++ ":\n" ++ intercalate "\n" (fmap ((++) "  ") body)
+nasmDeclaration (ManualVariable v _ _)                    body  = v ++ ":\n" ++ intercalate "\n" (fmap ((++) "  ") body)
+nasmDeclaration (GlobalVariable   n t (IntegerLiteral l)) _     = n ++ ": "  ++ nasmType t ++ " " ++ show l
+nasmDeclaration (ConstantVariable n t (IntegerLiteral l)) _     = n ++ ": "  ++ nasmType t ++ " " ++ show l
 
+litType :: Literal -> Result TypeId
+litType l@(IntegerLiteral x) | x >= 0   && x < 65536 = Right 2
+                             | otherwise             = Left (BackendError (show l ++ " is not in [0; 65536)"))
 
-runNasm :: [(Section, Declaration, Tree [Instruction])] -> String
-runNasm = join . map mapper
-    where mapper (s, d, t) = nasmSection s [nasmDeclaration t d]
+nasmTypes = TypeConfig 
+    { types = (fmap . first) TypeName [("int8", 8), ("int16", 16), ("+literal+", 16)]
+    , pointerType = 1
+    , registers = zip (join $ fmap (\x -> fmap ((:) x . pure) "lhx") "abcd") (cycle [0, 0, 1])
+    , typeCasts = buildG (0, 3) [(0, 2), (1, 2)]
+    , literalType = litType }
 
+nasm = Backend 
+    { instruction = nasm16I
+    , bodyWrap    = id
+    , indent      = "  "
+    , section     = nasmSection
+    , declaration = nasmDeclaration
+    , typeConfig  = nasmTypes }

src/Kroha/Errors.hs

@@ -0,0 +1,40 @@
+module Kroha.Errors where
+
+import Kroha.Ast
+import Data.Bifunctor (bimap, first)
+import Data.Either (partitionEithers)
+import Data.Foldable (toList)
+import Data.List (intercalate)
+
+type Result a = Either Error a
+
+data Error 
+    = JoinedError [Error]
+    | ParserError String
+    | TypeCastError TypeName TypeName
+    | UnknownType TypeName
+    | UnknownRegister RegisterName
+    | VariableNotFound VariableName
+    | LabelNotFound Label
+    | BackendError String
+
+
+instance Show Error where
+    show (JoinedError errors)   = intercalate "\n" $ fmap show errors
+    show (ParserError message)  = "[Parser error]:\n" ++ (unlines . fmap ((++) "\t") . lines) message
+    show (TypeCastError t1 t2)  = "[Type error]: "    ++ "Can't cast from " ++ show t1 ++ " to " ++ show t2
+    show (UnknownType t)        = "[Type error]: "    ++ "Unknown type " ++ show t
+    show (UnknownRegister reg)  = "[Type error]: "    ++ "Unknown register name " ++ show reg
+    show (VariableNotFound var) = "[Scope error]: "   ++ "Variable " ++ var   ++ " not found in the scope"
+    show (LabelNotFound label)  = "[Scope error]: "   ++ "Label "    ++ label ++ " not found in the scope"
+    show (BackendError message) = "[Asm error]: \n"   ++ (unlines . fmap ((++) "\t") . lines) message
+
+firstE :: (a -> Error) -> Either a b -> Either Error b
+firstE = first
+
+partitionErrors :: [Either a b] -> Either [a] [b]
+partitionErrors e = let (a, b) = partitionEithers e in if (null a) then Right b else Left a
+
+sequenceErrors :: (Foldable f, Functor f) => ([a] -> c) -> f (Either a b) -> Either c (f b)
+sequenceErrors f e = bimap f (const g) $ partitionErrors (toList e)
+    where g = fmap (\(Right x) -> x) e

src/Kroha/Parser.hs

@@ -5,6 +5,7 @@
 module Kroha.Parser (Kroha.Parser.parse) where
 
 import           Kroha.Ast
+import           Kroha.Errors
 
 import           Data.Bifunctor     (bimap)
 import           Data.Maybe         (maybeToList)
@@ -92,5 +93,5 @@ frame p = Frame <$> fname <*> block p
 globals = frame hlasm <|> constant <|> globvar <|> manualFrame <|> manualVar
 program = keyword "program" *> braces (many globals)
 
-parse :: String -> Either String Program
-parse = bimap show Program . Text.Parsec.parse program ""
+parse :: String -> Result Program
+parse = bimap (ParserError . show) Program . Text.Parsec.parse program ""

src/Kroha/Scope.hs

@@ -1,11 +1,12 @@
 module Kroha.Scope where
 
-import Control.Monad (join)
 import Control.Monad.Zip (mzip, munzip, mzipWith)
 import Data.Maybe (mapMaybe)
 import Data.Tree (Tree(..))
+import Data.Bifunctor (first)
 
 import Kroha.Ast
+import Kroha.Errors
 
 data ScopeEffect 
     = FluentScope
@@ -62,12 +63,17 @@ scopeTree parent (Node effect childs) = Node (effect:parent) childScope
     where folder acc child = (rootLabel child : fst acc, snd acc ++ [scopeTree (fst acc) child])
           childScope = snd $ foldl folder (effect:parent, []) childs
 
-linkScope :: Tree ([ScopeEffect], Scope) -> Either (ScopeEffect) (Tree Scope)
-linkScope (Node (request, scope) childs) = join . fmap buildTree $ results
-    where results = traverse (\r -> findEither r scope >>= return . (,) r) request
-          buildTree request = sequence . traverse (Node request) $ traverse linkScope childs
+linkScope :: Tree ([ScopeEffect], Scope) -> Result (Tree Scope)
+linkScope = sequenceErrors JoinedError . fmap (first scopeError . result)
+    where result (request, scope) = traverse (\r -> findEither r scope >>= return . (,) r) request
+          scopeError (VariableScope var) = VariableNotFound var
+          scopeError (LabelScope label)  = LabelNotFound label
 
-linkProgram :: Program -> Either (ScopeEffect) (Tree Scope)
+declarationScope :: Program -> Scope
+declarationScope p@(Program declarations) = fmap (\(el, id) -> (dscope el, DeclarationLink el id)) $ zip declarations ids
+    where ids = let (Node _ forest) = progId p in fmap rootLabel forest
+
+linkProgram :: Program -> Result (Tree Scope)
 linkProgram program = linkScope (mzip requests scope)
     where (changes, requests) = munzip (localScope program)
-          scope = scopeTree [] (mzip changes (linksTree program))
+          scope = scopeTree (declarationScope program) (mzip changes (linksTree program))

src/Kroha/Stack.hs

@@ -2,24 +2,26 @@ module Kroha.Stack where
 
 import Data.Tree
 import Data.List (mapAccumL)
+import Data.Maybe (fromJust)
 
 import Kroha.Ast
 import Kroha.Types
 
 type StackRange = (Int, Int) {-offset, size-}
 
-stackVar :: PointerSize -> FrameElement -> Int
-stackVar ptr (VariableDeclaration (StackVariable _ t)) = typeSize ptr t
-stackVar _   _                                         = 0
+stackVar :: TypeConfig -> FrameElement -> Int
+stackVar tc (VariableDeclaration (StackVariable _ (PointerType _))) = snd $ types tc !! pointerType tc
+stackVar tc (VariableDeclaration (StackVariable _ t@(TypeName _)))  = fromJust $ lookup t (types tc) 
+stackVar _   _                                                      = 0
 
-frame :: PointerSize -> Tree FrameElement -> (Int, Tree StackRange)
+frame :: TypeConfig -> Tree FrameElement -> (Int, Tree StackRange)
 frame ptr tree = mapAccumL f 0 tree
     where f acc el = let size = stackVar ptr el in (acc + size, (if size > 0 then acc + size else 0, size))
 
-stackFrames :: PointerSize -> Program -> [(Int, Tree StackRange)]
+stackFrames :: TypeConfig -> Program -> [(Int, Tree StackRange)]
 stackFrames ptr (Program declarations) = fmap mapper declarations
     where mapper (Frame _ f) = frame ptr (selector id f)
           mapper _           = (0, Node (0, 0) [])
 
-stack :: PointerSize -> Program -> Tree StackRange
+stack :: TypeConfig -> Program -> Tree StackRange
 stack ptr program = Node (0, 0) (fmap (Node (0, 0) . pure . snd) (stackFrames ptr program))