release(v1.2): Growing trees

Kroha.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           Kroha
-version:        1.1.1.0
+version:        1.2.2.0
 description:    Please see the README on GitHub at <https://github.com/vorotynsky/Kroha#readme>
 homepage:       https://github.com/vorotynsky/Kroha#readme
 bug-reports:    https://github.com/vorotynsky/Kroha/issues
@@ -40,8 +40,10 @@ executable Kroha
       src
   build-depends:
       base >=4.7 && <5
+    , comonad >=5 && <5.1
     , containers ==0.6.*
     , extra >=1.0 && <1.8
+    , hashmap >=1.0.0 && <1.4
     , parsec >=3.1.0 && <=3.1.14.0
   default-language: Haskell2010
 
@@ -69,7 +71,9 @@ test-suite Kroha-tests
       Diff >=0.2 && <0.5
     , HUnit ==1.6.*
     , base >=4.7 && <5
+    , comonad >=5 && <5.1
     , containers ==0.6.*
     , extra >=1.0 && <1.8
+    , hashmap >=1.0.0 && <1.4
     , parsec >=3.1.0 && <=3.1.14.0
   default-language: Haskell2010

package.yaml

@@ -1,5 +1,5 @@
 name:                Kroha
-version:             1.1.1.0
+version:             1.2.2.0
 github:              "vorotynsky/Kroha"
 license:             GPL-3
 author:              "Vorotynsky Maxim"
@@ -23,6 +23,8 @@ dependencies:
 - containers >= 0.6 && < 0.7
 - parsec >= 3.1.0 && <= 3.1.14.0
 - extra >= 1.0 && < 1.8
+- comonad >= 5 && < 5.1
+- hashmap >= 1.0.0 && < 1.4
 
 executables:
   Kroha:

src/Kroha.hs

@@ -1,28 +1,36 @@
-module Kroha where
+module Kroha (kroha) where
 
-import           Control.Monad.Zip     (mzip)
 import           Data.Bifunctor        (first)
-import           Data.Tree             (Tree (..))
+import           Data.Foldable         (toList)
+import           Data.HashMap          (fromList, lookup)
 
+import           Kroha.Ast             (NodeId, Program, genId, pzip, pzip3)
+import           Kroha.Backends.Common (runBackend, typeConfig)
+import           Kroha.Backends.Nasm   (nasm)
+import           Kroha.Errors          (Result, showErrors)
+import           Kroha.Instructions    (instructions)
 import           Kroha.Parser          (parse)
-import           Kroha.Ast             (FrameElement (Instructions), selectorProg)
-import           Kroha.Scope           (linkProgram, linksTree)
-import           Kroha.Types           (resolve, typeCastsTree, TypeConfig(..))
+import           Kroha.Scope           (linkProgram)
 import           Kroha.Stack           (stack)
-import           Kroha.Instructions    (instructions)
-import           Kroha.Backends.Common (runBackend, Backend(typeConfig))
-import           Kroha.Backends.Nasm   (nasm)
+import           Kroha.Types           (resolve, typeCastsTree)
+
+
+compile :: Program NodeId -> Result String
+compile program = do
+                  scopes  <- linkProgram program
+                  let tc   = typeConfig nasm
+                  casts   <- typeCastsTree tc scopes
+                  types   <- resolve tc (pzip program casts)
+                  let stackRanges = stack tc program
+                  let prepared = instructions (pzip3 stackRanges (fmap snd scopes) program)
+                  return (runBackend nasm prepared)
+
+kroha :: String -> String -> Either String String
+kroha name src =
+      case parse name src of
+           Left err   -> Left err
+           Right parsed -> first (showErrors (`Data.HashMap.lookup` rangeTable)) $ compile prog
+              where prog = genId parsed
+                    rangeTable = fromList $ toList $ pzip prog parsed
 
 
-kroha :: String -> Either String String
-kroha src = first show compile
-    where compile = do
-                    program <- parse src
-                    scopes  <- linkProgram program
-                    let programTree = Node (Instructions []) (selectorProg (const $ Instructions []) id 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 (runBackend nasm prepared)

src/Kroha/Ast.hs

@@ -1,9 +1,14 @@
--- Copyright (c) 2020 Vorotynsky Maxim
+-- Copyright (c) 2020 - 2021 Vorotynsky Maxim
+
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Kroha.Ast where
 
+import Control.Comonad
 import Data.Tree
 import Data.List (mapAccumR)
+import Control.Monad.Zip (mzipWith)
 
 type VariableName = String
 type RegisterName = String
@@ -35,65 +40,115 @@ data LocalVariable
     deriving (Show, Eq)
 
 data Comparator
-    = Equals    | NotEquals 
-    | Greater   | Less 
+    = Equals    | NotEquals
+    | Greater   | Less
     deriving (Show, Eq)
 
 newtype Condition = Condition (RValue, Comparator, RValue)
     deriving (Show, Eq)
 
-data FrameElement
-    = Instructions [FrameElement]
-    | VariableDeclaration LocalVariable
-    | If Label Condition FrameElement FrameElement
-    | Loop Label FrameElement
-    | Break Label
-    | Call Label [RValue]
-    | Assignment LValue RValue
-    | Inline InlinedCode 
-    deriving (Show, Eq)
-
-
-data Declaration
-    = Frame Label FrameElement
-    | GlobalVariable VariableName TypeName Literal
-    | ConstantVariable VariableName TypeName Literal
-    | ManualFrame Label InlinedCode
-    | ManualVariable VariableName TypeName InlinedCode 
-    deriving (Show, Eq)
-
-newtype Program = Program [Declaration]
-    deriving (Show, Eq)
-
-type Selector a = FrameElement -> a
-
-childs :: FrameElement -> [FrameElement]
-childs (Instructions xs)       = xs 
-childs (VariableDeclaration x) = []
-childs (If _ _ b e)            = [b, e]
-childs (Loop _ b)              = [b]
-childs (Break _)               = []
-childs (Call _ _)              = []
-childs (Assignment _ _)        = []
-childs (Inline _)              = []
-
-selector :: Selector a -> FrameElement -> Tree a
+data FrameElement d
+    = Instructions [FrameElement d] d
+    | VariableDeclaration LocalVariable d
+    | If Label Condition (FrameElement d) (FrameElement d) d
+    | Loop Label (FrameElement d) d
+    | Break Label d
+    | Call Label [RValue] d
+    | Assignment LValue RValue d
+    | Inline InlinedCode d
+    deriving (Show, Eq, Functor, Foldable, Traversable)
+
+
+data Declaration d
+    = Frame Label (FrameElement d) d
+    | GlobalVariable VariableName TypeName Literal d
+    | ConstantVariable VariableName TypeName Literal d
+    | ManualFrame Label InlinedCode d
+    | ManualVariable VariableName TypeName InlinedCode d
+    deriving (Show, Eq, Functor, Foldable, Traversable)
+
+data Program d = Program [Declaration d] d
+    deriving (Show, Eq, Functor, Foldable, Traversable)
+
+childs :: FrameElement d -> [FrameElement d]
+childs (Instructions xs _)       = xs
+childs (VariableDeclaration x _) = []
+childs (If _ _ b e _)            = [b, e]
+childs (Loop _ b _)              = [b]
+childs (Break _ _)               = []
+childs (Call _ _ _)              = []
+childs (Assignment _ _ _)        = []
+childs (Inline _ _)              = []
+
+getDeclData :: Declaration d -> d
+getDeclData (Frame _ _ d)              = d
+getDeclData (GlobalVariable _ _ _ d)   = d
+getDeclData (ConstantVariable _ _ _ d) = d
+getDeclData (ManualFrame _ _ d)        = d
+getDeclData (ManualVariable _ _ _ d)   = d
+
+
+
+selector :: (FrameElement d -> a) -> FrameElement d -> Tree a
 selector s = unfoldTree (\e -> (s e, childs e))
 
-selectorM :: Monad m => Selector (m a) -> FrameElement -> m (Tree a)
-selectorM s = unfoldTreeM (\e -> s e >>= (\x -> return (x, childs e)))
-
-
-selectorProg :: (Declaration -> a) -> Selector a -> Program -> Forest a
-selectorProg df sf (Program declarations) = fmap mapper declarations
-    where mapper d@(Frame _ frame) = Node (df d) [selector sf frame]
-          mapper declaration = Node (df declaration) []
+selectorProg :: (Declaration d -> a) -> (FrameElement d -> a) -> Program d -> Forest a
+selectorProg df sf (Program declarations _) = fmap mapper declarations
+    where mapper d@(Frame _ frame _)        = Node (df d) [selector sf frame]
+          mapper declaration                = Node (df declaration) []
 
 
 type NodeId = Int
 
-genId :: Tree a -> Tree NodeId
-genId = snd . mapAccumR (\ac b -> (ac + 1, ac)) 0
-
-progId :: Program -> Tree NodeId
-progId program = genId $ Node () (selectorProg (const ()) (const ()) program)
+genId :: Program d -> Program NodeId
+genId (Program decls _) = Program (snd $ mapAccumR declId 1 decls) 0
+    where genId'' = mapAccumR (\ac b -> (ac + 1, ac))
+          declId begin (Frame l fe _) = let (acc, fe') = genId'' (begin + 1) fe in (acc, Frame l fe' begin)
+          declId begin d  = (begin + 1, d $> begin)
+
+progId :: Program d -> Tree NodeId
+progId program = Node 0 $ selectorProg getDeclData extract (genId program)
+
+instance Comonad FrameElement where
+    duplicate node@(Instructions c _)        = Instructions (map duplicate c) node
+    duplicate node@(VariableDeclaration v _) = VariableDeclaration v node
+    duplicate node@(If l c i e _)            = If l c (duplicate i) (duplicate e) node
+    duplicate node@(Loop l b _)              = Loop l (duplicate b) node
+    duplicate node@(Break l _)               = Break l node
+    duplicate node@(Call l a _)              = Call l a node
+    duplicate node@(Assignment l r _)        = Assignment l r node
+    duplicate node@(Inline c _)              = Inline c node
+
+    extract (Instructions _ d)        = d
+    extract (VariableDeclaration _ d) = d
+    extract (If _ _ _ _ d)            = d
+    extract (Loop _ _ d)              = d
+    extract (Break _ d)               = d
+    extract (Call _ _ d)              = d
+    extract (Assignment _ _ d)        = d
+    extract (Inline _ d)              = d
+
+tzip :: FrameElement a -> FrameElement b -> FrameElement (a, b)
+tzip (Instructions ca _a)           (Instructions cb _b)                               = Instructions (uncurry tzip <$> zip ca cb) (_a, _b)
+tzip (VariableDeclaration va _a)    (VariableDeclaration vb _b) |  va      ==  vb      = VariableDeclaration va                    (_a, _b)
+tzip (If la ca ia ea _a)            (If lb cb ib eb _b)         | (la, ca) == (lb, cb) = If la ca  (tzip ia ib) (tzip ea eb)       (_a, _b)
+tzip (Loop la ba _a)                (Loop lb bb _b)             |  la      ==  lb      = Loop       la (tzip ba bb)                (_a, _b)
+tzip (Break la _a)                  (Break lb _b)               |  la      ==  lb      = Break      la                             (_a, _b)
+tzip (Call la aa _a)                (Call lb ab _b)             | (la, aa) == (lb, ab) = Call       la aa                          (_a, _b)
+tzip (Assignment la ra _a)          (Assignment lb rb _b)       | (la, ra) == (lb, rb) = Assignment la ra                          (_a, _b)
+tzip (Inline ca _a)                 (Inline cb _b)              |  ca      ==  cb      = Inline     ca                             (_a, _b)
+tzip _ _ = error "can't zip different frame elements"
+
+dzip :: Declaration a -> Declaration b -> Declaration (a, b)
+dzip (Frame la fea _a)              (Frame lb feb _b)              |  la          ==  lb          = Frame la (tzip fea feb)   (_a, _b)
+dzip (GlobalVariable va ta la _a)   (GlobalVariable vb tb lb _b)   | (va, ta, la) == (vb, tb, lb) = GlobalVariable   va ta la (_a, _b)
+dzip (ConstantVariable va ta la _a) (ConstantVariable vb tb lb _b) | (va, ta, la) == (vb, tb, lb) = ConstantVariable va ta la (_a, _b)
+dzip (ManualFrame la ca _a)         (ManualFrame lb cb _b)         | (la, ca)     == (lb, cb)     = ManualFrame la ca         (_a, _b)
+dzip (ManualVariable va ta ca _a)   (ManualVariable vb tb cb _b)   | (va, ta, ca) == (vb, tb, cb) = ManualVariable   va ta ca (_a, _b)
+dzip _ _ = error "can't zip different declarations"
+
+pzip :: Program a -> Program b -> Program (a, b)
+pzip (Program da _a) (Program db _b) = Program (mzipWith dzip da db) (_a, _b)
+
+pzip3 :: Program a -> Program b -> Program c -> Program (a, b, c)
+pzip3 a b c = fmap (\((a, b), c) -> (a, b, c)) (pzip (pzip a b) c)

src/Kroha/Backends/Common.hs

@@ -4,7 +4,7 @@ import Kroha.Ast (Declaration(..))
 import Kroha.Types (TypeConfig)
 import Kroha.Instructions (Instruction(Body), Section)
 
-import Control.Monad (join)
+import Control.Monad (join, void)
 import Data.Tree (Tree(..))
 import Data.Char (isSpace)
 import Data.Semigroup (Min(Min, getMin))
@@ -16,7 +16,7 @@ data Backend = Backend
     , bodyWrap :: [String] -> [String]
     , indent :: String
     , section :: Section -> String -> String
-    , declaration :: Declaration -> [String] -> String }
+    , declaration :: Declaration () -> [String] -> String }
 
 
 makeFix :: Backend -> Tree [Instruction] -> [String]
@@ -30,14 +30,14 @@ unindentManual code = fmap (drop minIndent) lined
           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)
+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 -> [(Section, Declaration d, Tree [Instruction])] -> String
 runBackend backend = join . fmap (mapper)
-    where mapper (s, d, i) = section backend s (backendDeclaration backend d i)
+    where mapper (s, d, i) = section backend s (backendDeclaration backend (void d) i)
 

src/Kroha/Backends/Nasm.hs

@@ -57,13 +57,13 @@ nasmSection :: Section -> String -> String
 nasmSection section body = header <> body <> "\n\n"
     where header = "section ." ++ section ++ "\n"
 
-nasmDeclaration :: Declaration -> [String] -> String
-nasmDeclaration (Frame l _)                               body  = l ++ ":\n" ++ intercalate "\n" body ++ "\nleave\nret"
-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 ++ ": "  ++ nasmTypeG t ++ " " ++ show l
-nasmDeclaration (ConstantVariable n t (IntegerLiteral l)) _     = n ++ ": "  ++ nasmTypeG t ++ " " ++ show l
+nasmDeclaration :: Declaration d -> [String] -> String
+nasmDeclaration (Frame l _ _)                               body  = l ++ ":\n" ++ intercalate "\n" body ++ "\nleave\nret"
+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 ++ ": "  ++ nasmTypeG t ++ " " ++ show l
+nasmDeclaration (ConstantVariable n t (IntegerLiteral l) _) _     = n ++ ": "  ++ nasmTypeG t ++ " " ++ show l
 
 litType :: Literal -> Result TypeId
 litType l@(IntegerLiteral x) | x >= 0   && x < 65536 = Right 2