Sockeye: Collect errors in type checker instead of failing at first one
[barrelfish] / tools / sockeye / SockeyeInstantiator.hs
index c69d86d..26d07b3 100644 (file)
@@ -18,7 +18,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 
 module SockeyeInstantiator
-( sockeyeInstantiate ) where
+( instantiateSockeye ) where
 
 import Control.Monad.State
 
@@ -33,13 +33,13 @@ import Numeric (showHex)
 
 import SockeyeChecks
 
-import qualified SockeyeAST as AST
+import qualified SockeyeASTTypeChecker as CheckAST
 import qualified SockeyeASTInstantiator as InstAST
 
 import Text.Groom (groom)
 import Debug.Trace
 
-data InstFails
+data InstFail
     = ModuleInstLoop     [String]
     | DuplicateNamespace !String
     | DuplicateIdentifer !String
@@ -51,7 +51,7 @@ data InstFails
     | UndefinedInPort    !String !String
     | UndefinedReference !String !String
 
-instance Show InstFails where
+instance Show InstFail where
     show (ModuleInstLoop     loop)       = concat ["Module instantiation loop: '", intercalate "' -> '" loop, "'"]
     show (DuplicateInPort    port)       = concat ["Multiple declarations of input port '", port, "'"]
     show (DuplicateOutPort   port)       = concat ["Multiple declarations of output port '", port, "'"]
@@ -63,19 +63,20 @@ instance Show InstFails where
     show (UndefinedOutPort inst port)    = concat ["Mapping to undefined output port '",  port, "' in module instantiation '", inst, "'"]
     show (UndefinedReference decl ident) = concat ["Reference to undefined node '", ident, "' in declaration of node '", decl, "'"]
 
+type PortMapping = (InstAST.Identifier, InstAST.Identifier)
+
 data Context = Context
-    { spec        :: AST.SockeyeSpec
+    { modules     :: Map String CheckAST.Module
     , modulePath  :: [String]
     , paramValues :: Map String Integer
     , varValues   :: Map String Integer
     }
 
-sockeyeInstantiate :: AST.SockeyeSpec -> Either (FailedChecks InstFails) InstAST.SockeyeSpec
-sockeyeInstantiate ast = do
-    let
-        emptySpec = AST.SockeyeSpec Map.empty
+instantiateSockeye :: CheckAST.SockeyeSpec -> Either (FailedChecks InstFail) InstAST.SockeyeSpec
+instantiateSockeye ast = do
+    let emptySpec = CheckAST.SockeyeSpec 
         context = Context
-            { spec        = emptySpec
+            { modules     = Map.empty
             , modulePath  = []
             , paramValues = Map.empty
             , varValues   = Map.empty
@@ -86,34 +87,26 @@ sockeyeInstantiate ast = do
 -- Instantiate Module Templates
 --
 class Instantiatable a b where
-    instantiate :: Context -> a -> StateT (Map String InstAST.Module) (Checks InstFails) b
+    instantiate :: Context -> a -> StateT (Map String InstAST.Module) (Checks InstFail) b
 
-instance Instantiatable AST.SockeyeSpec InstAST.SockeyeSpec where
+instance Instantiatable CheckAST.SockeyeSpec InstAST.SockeyeSpec where
     instantiate context ast = do
-        let
-            rootInst = AST.ModuleInst
-                { AST.namespace  = AST.SimpleIdent ""
-                , AST.moduleName = "@root"
-                , AST.arguments  = Map.empty
-                , AST.inPortMap  = []
-                , AST.outPortMap = []
-                }
+        let root = CheckAST.root ast
+            mods  = CheckAST.modules ast
             specContext = context
-                { spec = ast }
-        [("", instRoot)] <- instantiate specContext rootInst
+                { modules = mods }
+        [instRoot] <- instantiate specContext root
         modules <- get
         return InstAST.SockeyeSpec
             { InstAST.root = instRoot
             , InstAST.modules = modules
             }
 
-instance Instantiatable AST.Module InstAST.Module where
+instance Instantiatable CheckAST.Module InstAST.Module where
     instantiate context ast = do
-        let
-            inPorts = AST.inputPorts ast
-            outPorts = AST.outputPorts ast
-            nodeDecls = AST.nodeDecls ast
-            moduleInsts = AST.moduleInsts ast
+        let ports = CheckAST.ports ast
+            nodeDecls = CheckAST.nodeDecls ast
+            moduleInsts = CheckAST.moduleInsts ast
             modName = head $ modulePath context
         modules <- get
         if modName `Map.member` modules
@@ -121,69 +114,80 @@ instance Instantiatable AST.Module InstAST.Module where
                 return $ modules Map.! modName
             else do
                 let sentinel = InstAST.Module
-                        { InstAST.inputPorts   = Map.empty
-                        , InstAST.outputPorts  = Map.empty
-                        , InstAST.nodeDecls    = Map.empty
-                        , InstAST.moduleInsts  = Map.empty
+                        { InstAST.ports       = []
+                        , InstAST.nodeDecls   = []
+                        , InstAST.moduleInsts = []
                         }
                 modify $ Map.insert modName sentinel
-                instInPorts <- do
-                    instPorts <- instantiate context inPorts
-                    return $ concat (instPorts :: [[(String, Integer)]])
-                instOutPorts <- do
-                    instPorts <- instantiate context outPorts
-                    return $ concat (instPorts :: [[(String, Integer)]])
+                instPorts <- do
+                    instPorts <- instantiate context ports
+                    return $ concat (instPorts :: [[InstAST.Port]])
                 instDecls <- do
                     decls <- instantiate context nodeDecls
-                    return $ concat (decls :: [[(String, InstAST.NodeSpec)]])
+                    return $ concat (decls :: [[InstAST.NodeDecl]])
                 instInsts <- do
                     insts <- instantiate context moduleInsts
-                    return $ concat (insts :: [[(String, InstAST.ModuleInst)]])
-                lift $ checkDuplicates modName DuplicateInPort    $ (map fst instInPorts)
-                lift $ checkDuplicates modName DuplicateOutPort   $ (map fst instOutPorts)
-                lift $ checkDuplicates modName DuplicateIdentifer $ (map fst instDecls)
-                lift $ checkDuplicates modName DuplicateNamespace $ (map fst instInsts)
+                    return $ concat (insts :: [[InstAST.ModuleInst]])
+                lift $ checkDuplicates modName DuplicateInPort    $ (map InstAST.portId $ filter isInPort  instPorts)
+                lift $ checkDuplicates modName DuplicateOutPort   $ (map InstAST.portId $ filter isOutPort instPorts)
+                lift $ checkDuplicates modName DuplicateIdentifer $ (map InstAST.nodeId instDecls)
+                lift $ checkDuplicates modName DuplicateNamespace $ (map InstAST.namespace instInsts)
+                -- TODO: check duplicates with input/output ports
                 return InstAST.Module
-                    { InstAST.inputPorts   = Map.fromList instInPorts
-                    , InstAST.outputPorts  = Map.fromList instOutPorts
-                    , InstAST.nodeDecls    = Map.fromList instDecls
-                    , InstAST.moduleInsts  = Map.fromList instInsts
+                    { InstAST.ports       = instPorts
+                    , InstAST.nodeDecls   = instDecls
+                    , InstAST.moduleInsts = instInsts
                     }
+        where
+            isInPort  (InstAST.InputPort  {}) = True
+            isInPort  (InstAST.OutputPort {}) = False
+            isOutPort (InstAST.InputPort  {}) = False
+            isOutPort (InstAST.OutputPort {}) = True
 
-instance Instantiatable AST.Port [(String, Integer)] where
-    instantiate context (AST.MultiPort for) = do
+instance Instantiatable CheckAST.Port [InstAST.Port] where
+    instantiate context (CheckAST.MultiPort for) = do
         instFor <- instantiate context for
-        return $ concat (instFor :: [[(String, Integer)]])
-    instantiate context ast = do
-        let
-            ident = AST.portId ast
-            width = AST.portWidth ast
+        return $ concat (instFor :: [[InstAST.Port]])
+    instantiate context ast@(CheckAST.InputPort {}) = do
+        let ident = CheckAST.portId ast
+            width = CheckAST.portWidth ast
         instIdent <- instantiate context ident
-        return [(instIdent, width)]
+        let instPort = InstAST.InputPort
+                { InstAST.portId    = instIdent
+                , InstAST.portWidth = width
+                }
+        return [instPort]
+    instantiate context ast@(CheckAST.OutputPort {}) = do
+        let ident = CheckAST.portId ast
+            width = CheckAST.portWidth ast
+        instIdent <- instantiate context ident
+        let instPort = InstAST.OutputPort
+                { InstAST.portId    = instIdent
+                , InstAST.portWidth = width
+                }
+        return [instPort]
 
-instance Instantiatable AST.ModuleInst [(String, InstAST.ModuleInst)] where
-    instantiate context (AST.MultiModuleInst for) = do 
+instance Instantiatable CheckAST.ModuleInst [InstAST.ModuleInst] where
+    instantiate context (CheckAST.MultiModuleInst for) = do 
         simpleFor <- instantiate context for
-        return $ concat (simpleFor :: [[(String, InstAST.ModuleInst)]])
+        return $ concat (simpleFor :: [[InstAST.ModuleInst]])
     instantiate context ast = do
-        let
-            namespace = AST.namespace ast
-            name = AST.moduleName ast
-            args = AST.arguments ast
-            inPortMap = AST.inPortMap ast
-            outPortMap = AST.outPortMap ast
+        let namespace = CheckAST.namespace ast
+            name = CheckAST.moduleName ast
+            args = CheckAST.arguments ast
+            inPortMap = CheckAST.inPortMap ast
+            outPortMap = CheckAST.outPortMap ast
             modPath = modulePath context
             mod = getModule context name
         instNs <- instantiate context namespace
         instInMap <- do
             inMaps <- instantiate context inPortMap
-            return $ concat (inMaps :: [[(String, String)]])
+            return $ concat (inMaps :: [[PortMapping]])
         instOutMap <- do
             outMaps <- instantiate context outPortMap
-            return $ concat (outMaps :: [[(String, String)]])
+            return $ concat (outMaps :: [[PortMapping]])
         instArgs <- instantiate context args
-        let
-            instName = concat [name, "(", intercalate ", " $ argStrings instArgs mod, ")"]
+        let instName = concat [name, "(", intercalate ", " $ argStrings instArgs mod, ")"]
             moduleContext = context
                     { modulePath  = instName:modPath
                     , paramValues = instArgs
@@ -192,25 +196,24 @@ instance Instantiatable AST.ModuleInst [(String, InstAST.ModuleInst)] where
         lift $ checkSelfInst modPath instName
         lift $ checkDuplicates name (DuplicateInMap  instName) $ map fst instInMap
         lift $ checkDuplicates name (DuplicateOutMap instName) $ map fst instOutMap
-        let
-            simplified = InstAST.ModuleInst
+        let instantiated = InstAST.ModuleInst
                 { InstAST.moduleName = instName
+                , InstAST.namespace  = instNs
                 , InstAST.inPortMap  = Map.fromList instInMap
                 , InstAST.outPortMap = Map.fromList instOutMap
                 }
         instModule <- instantiate moduleContext mod
         modify $ Map.insert instName instModule
-        return [(instNs, simplified)]
+        return [instantiated]
         where
             argStrings args mod =
-                let
-                    paramNames = AST.paramNames mod
-                    paramTypes = AST.paramTypeMap mod
+                let paramNames = CheckAST.paramNames mod
+                    paramTypes = CheckAST.paramTypeMap mod
                     params = map (\p -> (p, paramTypes Map.! p)) paramNames
                 in map showValue params
                     where
-                        showValue (name, AST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
-                        showValue (name, AST.NaturalParam) = show (args Map.! name)
+                        showValue (name, CheckAST.AddressParam)  = "0x" ++ showHex (args Map.! name) ""
+                        showValue (name, CheckAST.NaturalParam) = show (args Map.! name)
             checkSelfInst path name = do
                 case loop path of
                     [] -> return ()
@@ -221,57 +224,57 @@ instance Instantiatable AST.ModuleInst [(String, InstAST.ModuleInst)] where
                             | name `elem` path = p:(loop ps)
                             | otherwise = []
 
-instance Instantiatable AST.ModuleArg Integer where
-    instantiate _ (AST.AddressArg v) = return v
-    instantiate _ (AST.NaturalArg v) = return v
-    instantiate context (AST.ParamArg name) = return $ getParamValue context name
+instance Instantiatable CheckAST.ModuleArg Integer where
+    instantiate _ (CheckAST.AddressArg value) = return value
+    instantiate _ (CheckAST.NaturalArg value) = return value
+    instantiate context (CheckAST.ParamArg name) = return $ getParamValue context name
 
-instance Instantiatable AST.PortMap [(String, String)] where
-    instantiate context (AST.MultiPortMap for) = do
+instance Instantiatable CheckAST.PortMap [PortMapping] where
+    instantiate context (CheckAST.MultiPortMap for) = do
         instFor <- instantiate context for
-        return $ concat (instFor :: [[(String, String)]])
+        return $ concat (instFor :: [[PortMapping]])
     instantiate context ast = do
-        let
-            mappedId = AST.mappedId ast
-            mappedPort = AST.mappedPort ast
+        let mappedId = CheckAST.mappedId ast
+            mappedPort = CheckAST.mappedPort ast
         instId <- instantiate context mappedId
         instPort <- instantiate context mappedPort
         return [(instPort, instId)]
 
-instance Instantiatable AST.NodeDecl [(String, InstAST.NodeSpec)] where
-    instantiate context (AST.MultiNodeDecl for) = do
+instance Instantiatable CheckAST.NodeDecl [InstAST.NodeDecl] where
+    instantiate context (CheckAST.MultiNodeDecl for) = do
         instFor <- instantiate context for
-        return $ concat (instFor :: [[(String, InstAST.NodeSpec)]])
+        return $ concat (instFor :: [[InstAST.NodeDecl]])
     instantiate context ast = do
-        let
-            nodeId = AST.nodeId ast
-            nodeSpec = AST.nodeSpec ast
+        let nodeId = CheckAST.nodeId ast
+            nodeSpec = CheckAST.nodeSpec ast
         instNodeId <- instantiate context nodeId
         instNodeSpec <- instantiate context nodeSpec
-        return [(instNodeId, instNodeSpec)]
+        let instDecl = InstAST.NodeDecl
+                { InstAST.nodeId   = instNodeId
+                , InstAST.nodeSpec = instNodeSpec
+                }
+        return $ [instDecl]
 
-instance Instantiatable AST.Identifier String where
-    instantiate context (AST.SimpleIdent name) = do
+instance Instantiatable CheckAST.Identifier InstAST.Identifier where
+    instantiate context (CheckAST.SimpleIdent name) = do
         return name
     instantiate context ast = do
-        let
-            prefix = AST.prefix ast
-            varName = AST.varName ast
-            suffix = AST.suffix ast
+        let prefix = CheckAST.prefix ast
+            varName = CheckAST.varName ast
+            suffix = CheckAST.suffix ast
             varValue = show $ getVarValue context varName
         suffixName <- case suffix of
             Nothing -> return ""
             Just s  -> instantiate context s
         return $ prefix ++ varValue ++ suffixName
 
-instance Instantiatable AST.NodeSpec InstAST.NodeSpec where
+instance Instantiatable CheckAST.NodeSpec InstAST.NodeSpec where
     instantiate context ast = do
-        let
-            nodeType = AST.nodeType ast
-            accept = AST.accept ast
-            translate = AST.translate ast
-            reserved = AST.reserved ast
-            overlay = AST.overlay ast
+        let nodeType = CheckAST.nodeType ast
+            accept = CheckAST.accept ast
+            translate = CheckAST.translate ast
+            reserved = CheckAST.reserved ast
+            overlay = CheckAST.overlay ast
         instAccept <- instantiate context accept
         instTranslate <- instantiate context translate
         instReserved <- instantiate context reserved
@@ -284,74 +287,69 @@ instance Instantiatable AST.NodeSpec InstAST.NodeSpec where
             , InstAST.overlay   = instOverlay
             }
 
-instance Instantiatable AST.NodeType InstAST.NodeType where
-    instantiate _ AST.Memory = return InstAST.Memory
-    instantiate _ AST.Device = return InstAST.Device
-    instantiate _ AST.Other  = return InstAST.Other
+instance Instantiatable CheckAST.NodeType InstAST.NodeType where
+    instantiate _ CheckAST.Memory = return InstAST.Memory
+    instantiate _ CheckAST.Device = return InstAST.Device
+    instantiate _ CheckAST.Other  = return InstAST.Other
 
-instance Instantiatable AST.BlockSpec InstAST.BlockSpec where
-    instantiate context (AST.SingletonBlock base) = do
+instance Instantiatable CheckAST.BlockSpec InstAST.BlockSpec where
+    instantiate context (CheckAST.SingletonBlock base) = do
         instBase <- instantiate context base
         return InstAST.BlockSpec
             { InstAST.base  = instBase
             , InstAST.limit = instBase
             }
-    instantiate context (AST.RangeBlock base limit) = do
+    instantiate context (CheckAST.RangeBlock base limit) = do
         instBase <- instantiate context base
         instLimit <- instantiate context limit
         return InstAST.BlockSpec
             { InstAST.base  = instBase
             , InstAST.limit = instLimit
             }
-    instantiate context (AST.LengthBlock base bits) = do
+    instantiate context (CheckAST.LengthBlock base bits) = do
         instBase <- instantiate context base
-        let
-            instLimit = instBase + 2^bits - 1
+        let instLimit = instBase + 2^bits - 1
         return InstAST.BlockSpec
             { InstAST.base  = instBase
             , InstAST.limit = instLimit
             }
 
-instance Instantiatable AST.MapSpec InstAST.MapSpec where
+instance Instantiatable CheckAST.MapSpec InstAST.MapSpec where
     instantiate context ast = do
-        let
-            block = AST.block ast
-            destNode = AST.destNode ast
-            destBase = fromMaybe (AST.base block) (AST.destBase ast)
+        let block = CheckAST.block ast
+            destNode = CheckAST.destNode ast
+            destBase = fromMaybe (CheckAST.base block) (CheckAST.destBase ast)
         instBlock <- instantiate context block
         instDestNode <- instantiate context destNode
         instDestBase <- instantiate context destBase
         return InstAST.MapSpec
-            { InstAST.block    = instBlock
+            { InstAST.srcBlock    = instBlock
             , InstAST.destNode = instDestNode
             , InstAST.destBase = instDestBase
             }
 
-instance Instantiatable AST.OverlaySpec InstAST.OverlaySpec where
+instance Instantiatable CheckAST.OverlaySpec InstAST.OverlaySpec where
     instantiate context ast = do
-        let
-            over = AST.over ast
-            width = AST.width ast
+        let over = CheckAST.over ast
+            width = CheckAST.width ast
         instOver <- instantiate context over
         return InstAST.OverlaySpec
             { InstAST.over  = instOver
             , InstAST.width = width
             }
 
-instance Instantiatable AST.Address Integer where
-    instantiate context (AST.ParamAddress name) = do
+instance Instantiatable CheckAST.Address InstAST.Address where
+    instantiate context (CheckAST.ParamAddress name) = do
         let value = getParamValue context name
         return value
-    instantiate _ (AST.LiteralAddress value) = return value
+    instantiate _ (CheckAST.LiteralAddress value) = return value
 
-instance Instantiatable a b => Instantiatable (AST.For a) [b] where
+instance Instantiatable a b => Instantiatable (CheckAST.For a) [b] where
     instantiate context ast = do
-        let
-            body = AST.body ast
-            varRanges = AST.varRanges ast
+        let body = CheckAST.body ast
+            varRanges = CheckAST.varRanges ast
         concreteRanges <- instantiate context varRanges
-        let
-            valueList = Map.foldWithKey iterations [] concreteRanges
+        let valueList = Map.foldWithKey iterations [] concreteRanges
             iterContexts = map iterationContext valueList
         mapM (\c -> instantiate c body) iterContexts
         where
@@ -365,37 +363,31 @@ instance Instantiatable a b => Instantiatable (AST.For a) [b] where
                 in context
                     { varValues = values `Map.union` varMap }
 
-instance Instantiatable AST.ForRange [Integer] where
+instance Instantiatable CheckAST.ForRange [Integer] where
     instantiate context ast = do
-        let
-            start = AST.start ast
-            end = AST.end ast
+        let start = CheckAST.start ast
+            end = CheckAST.end ast
         simpleStart <- instantiate context start
         simpleEnd <- instantiate context end
         return [simpleStart..simpleEnd]
 
-instance Instantiatable AST.ForLimit Integer where
-    instantiate _ (AST.LiteralLimit value) = return value
-    instantiate context (AST.ParamLimit name) = return $ getParamValue context name
+instance Instantiatable CheckAST.ForLimit Integer where
+    instantiate _ (CheckAST.LiteralLimit value) = return value
+    instantiate context (CheckAST.ParamLimit name) = return $ getParamValue context name
 
 instance (Traversable t, Instantiatable a b) => Instantiatable (t a) (t b) where
     instantiate context ast = mapM (instantiate context) ast
 
 
-getModule :: Context -> String -> AST.Module
-getModule context name =
-    let
-        modules = AST.modules $ spec context
-    in modules Map.! name
+getModule :: Context -> String -> CheckAST.Module
+getModule context name = (modules context) Map.! name
 
 getParamValue :: Context -> String -> Integer
 getParamValue context name =
-    let
-        params = paramValues context
+    let params = paramValues context
     in params Map.! name
 
 getVarValue :: Context -> String -> Integer
 getVarValue context name =
-    let
-        vars = varValues context
+    let vars = varValues context
     in vars Map.! name