ddc-build 0.4.1.3 → 0.4.2.1

raw patch · 24 files changed

+1486/−365 lines, 24 filesdep +ddc-core-babeldep +timedep −ddc-core-evaldep ~basedep ~ddc-basedep ~ddc-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ddc-core-babel, time

Dependencies removed: ddc-core-eval

Dependency ranges changed: base, ddc-base, ddc-core, ddc-core-flow, ddc-core-llvm, ddc-core-salt, ddc-core-simpl, ddc-core-tetra, ddc-source-tetra, deepseq, filepath, mtl

API changes (from Hackage documentation)

Files

• DDC/Build/Builder.hs +62/−40
• DDC/Build/Interface/Base.hs +93/−0
• DDC/Build/Interface/Load.hs +285/−0
• DDC/Build/Interface/Store.hs +256/−0
• DDC/Build/Language.hs +2/−8
• DDC/Build/Language/Base.hs +3/−1
• DDC/Build/Language/Eval.hs +0/−75
• DDC/Build/Language/Flow.hs +4/−5
• DDC/Build/Language/Lite.hs +0/−73
• DDC/Build/Language/Salt.hs +11/−11
• DDC/Build/Language/Tetra.hs +0/−1
• DDC/Build/Language/Zero.hs +21/−5
• DDC/Build/Pipeline.hs +0/−4
• DDC/Build/Pipeline/Core.hs +130/−81
• DDC/Build/Pipeline/Error.hs +7/−6
• DDC/Build/Pipeline/Llvm.hs +4/−3
• DDC/Build/Pipeline/Salt.hs +6/−4
• DDC/Build/Pipeline/Text.hs +63/−32
• DDC/Build/Spec.hs +9/−0
• DDC/Build/Spec/Base.hs +73/−0
• DDC/Build/Spec/Check.hs +11/−0
• DDC/Build/Spec/Parser.hs +234/−0
• DDC/Build/Transform/Resolve.hs +186/−0
• ddc-build.cabal +26/−16

@@ -9,11 +9,13 @@ where import DDC.Build.Platform import DDC.Base.Pretty                          hiding ((</>))+import Data.List import System.FilePath                         -import System.Exit+import System.Exit                              hiding (die) import System.Process import qualified DDC.Core.Salt.Platform         as Llvm + -- | Configuration information for a builder that is not platform specific. data BuilderConfig         = BuilderConfig@@ -23,9 +25,12 @@            -- | Directory that holds the shared objects for the runtime           --   system and base library.-        , builderConfigBaseLibDir       :: FilePath }+        , builderConfigBaseLibDir       :: FilePath +          -- | Runtime library link with.+        , builderConfigLibFile          :: FilePath -> FilePath -> FilePath } + -- | Actions to use to invoke external compilation tools. data Builder         = Builder@@ -63,7 +68,7 @@         , buildAs               :: FilePath -> FilePath -> IO ()            -- | Link an executable.-        , buildLdExe            :: FilePath -> FilePath -> IO () +        , buildLdExe            :: [FilePath] -> FilePath -> IO ()             -- | Link a static library.         , buildLdLibStatic      :: [FilePath] -> FilePath -> IO ()@@ -175,19 +180,18 @@         , buildBaseSrcDir       = builderConfigBaseSrcDir config         , buildBaseLibDir       = builderConfigBaseLibDir config -        -- Use -disable-cfi to disable Call Frame Identification (CFI) directives-        -- because the OSX system assembler doesn't support them.         , buildLlc                     = \llFile sFile                 -> doCmd "LLVM compiler"        [(2, BuilderCanceled)]-                [ "llc -O3 -march=x86 -relocation-model=pic -disable-cfi" -                ,       llFile +                [ "opt -O3"+                , llFile+                , "| llc -O3 -march=x86 -relocation-model=pic"                 , "-o", sFile ]          , buildCC                 = \cFile oFile                 -> doCmd "C compiler"           [(2, BuilderCanceled)]-                [ "gcc -Werror -std=c99 -O3 -m32"+                [ "cc -Werror -std=c99 -O3 -m32"                 , "-c", cFile                 , "-o", oFile                 , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"@@ -196,17 +200,20 @@         , buildAs                 = \sFile oFile                 -> doCmd "assembler"            [(2, BuilderCanceled)]-                [ "as -arch i386"  +                [ "llvm-mc -arch x86 -filetype=obj"                   , "-o", oFile                 ,       sFile ]          , buildLdExe-                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]-                [ "gcc -m32" +                [ "cc -m32 -Wl,-dead_strip"                  , "-o", binFile-                , oFile-                , builderConfigBaseLibDir config </> "libddc-runtime.dylib" ]+                , intercalate " " oFiles+                , builderConfigBaseLibDir config+                        </> builderConfigLibFile config+                                "libddc-runtime.a"+                                "libddc-runtime.dylib" ]          , buildLdLibStatic                 = \oFiles libFile@@ -216,7 +223,7 @@         , buildLdLibShared                 = \oFiles libFile                 -> doCmd "linker"               [(2, BuilderCanceled)]-                $ [ "gcc -m32 -dynamiclib -undefined dynamic_lookup"+                $ [ "cc -m32 -dynamiclib -undefined dynamic_lookup"                   , "-o", libFile ] ++ oFiles         } @@ -230,19 +237,18 @@         , buildBaseSrcDir       = builderConfigBaseSrcDir config         , buildBaseLibDir       = builderConfigBaseLibDir config -        -- Use -disable-cfi to disable Call Frame Identification (CFI) directives-        -- because the OSX system assembler doesn't support them.         , buildLlc                     = \llFile sFile                 -> doCmd "LLVM compiler"        [(2, BuilderCanceled)]-                [ "llc -O3 -march=x86-64 -relocation-model=pic -disable-cfi" -                ,       llFile +                [ "opt -O3"+                , llFile+                , "| llc -O3 -march=x86-64 -relocation-model=pic"                 , "-o", sFile ]          , buildCC                 = \cFile oFile                 -> doCmd "C compiler"           [(2, BuilderCanceled)]-                [ "gcc -Werror -std=c99 -O3 -m64"+                [ "cc -Werror -std=c99 -O3 -m64"                 , "-c", cFile                 , "-o", oFile                 , "-I" ++ builderConfigBaseSrcDir config </> "sea/runtime"@@ -251,17 +257,20 @@         , buildAs                 = \sFile oFile                 -> doCmd "assembler"            [(2, BuilderCanceled)]-                [ "as -arch x86_64"  +                [ "llvm-mc -arch x86-64 -filetype=obj"                   , "-o", oFile                 ,       sFile ]          , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]-                [ "gcc -m64" +                [ "cc -m64 -Wl,-dead_strip"                  , "-o", binFile-                , oFile-                , builderConfigBaseLibDir config </> "libddc-runtime.dylib" ]+                , intercalate " " oFiles+                , builderConfigBaseLibDir config +                        </> builderConfigLibFile config +                                "libddc-runtime.a"+                                "libddc-runtime.dylib" ]          , buildLdLibStatic                 = \oFiles libFile@@ -271,7 +280,7 @@         , buildLdLibShared                 = \oFiles libFile                 -> doCmd "linker"               [(2, BuilderCanceled)]-                $ [ "gcc -m64 -dynamiclib -undefined dynamic_lookup"+                $ [ "cc -m64 -dynamiclib -undefined dynamic_lookup"                   , "-o", libFile ] ++ oFiles         } @@ -311,12 +320,15 @@                 ,       sFile ]          , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]                 [ "gcc -m32"                  , "-o", binFile-                , oFile-                , builderConfigBaseLibDir config </> "libddc-runtime.so" ]+                , intercalate " " oFiles+                , builderConfigBaseLibDir config +                        </> builderConfigLibFile config+                                "libddc-runtime.a"+                                "libddc-runtime.so" ]          , buildLdLibStatic                 = \oFiles libFile@@ -365,12 +377,15 @@                 , sFile ]           , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]                 [ "gcc -m64"                 , "-o", binFile-                , oFile-                , builderConfigBaseLibDir config </> "libddc-runtime.so" ]+                , intercalate " " oFiles+                , builderConfigBaseLibDir config+                        </> builderConfigLibFile config+                                "libddc-runtime.a"+                                "libddc-runtime.so" ]          , buildLdLibStatic                 = \oFiles libFile@@ -418,12 +433,15 @@                 , sFile ]          , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]                 [ "gcc -m32"                  , "-o", binFile-                , oFile-                , builderConfigBaseLibDir config </> "libddc-runtime.so" ]+                , intercalate " " $ map normalise oFiles+                , builderConfigBaseLibDir config+                        </> builderConfigLibFile config+                                "libddc-runtime.a"+                                "libddc-runtime.so" ]          , buildLdLibStatic                 = \oFiles libFile@@ -473,12 +491,14 @@     -- Note on Cygwin we need to use 'gcc-4' explicitly because plain 'gcc'     -- is a symlink, which Windows doesn't really support.         , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]                 [ "gcc-4 -m32"                  , "-o", normalise binFile-                , normalise oFile-                , normalise $ builderConfigBaseLibDir config </> "libddc-runtime.a" ]+                , intercalate " " $ map normalise oFiles+                , normalise $ builderConfigBaseLibDir config+                        </> "libddc-runtime.a" ] +                        -- configRuntimeLinkStrategy is ignored          , buildLdLibStatic                 = \oFiles libFile@@ -526,12 +546,14 @@                 , normalise sFile ]          , buildLdExe  -                = \oFile binFile+                = \oFiles binFile                 -> doCmd "linker"               [(2, BuilderCanceled)]                 [ "gcc -m32"                  , "-o", normalise binFile-                , normalise oFile-                , normalise $ builderConfigBaseLibDir config </> "libddc-runtime.a" ]+                , intercalate " " $ map normalise oFiles+                , normalise $ builderConfigBaseLibDir config +                        </> "libddc-runtime.a" ] +                        -- configRuntimeLinkStrategy is ignored          , buildLdLibStatic                 = \oFiles libFile

@@ -0,0 +1,93 @@++module DDC.Build.Interface.Base +        ( Interface (..)+        , makeInterfaceTearLine+        , takeInterfaceTearLine+        , isInterfaceTearLine)+where+import DDC.Core.Module+import DDC.Core.Pretty+import DDC.Core.Exp.Annot+import Data.Maybe+import Data.Time.Clock+import qualified Data.Char              as Char+import qualified DDC.Core.Tetra         as Tetra+import qualified DDC.Core.Salt          as Salt+++---------------------------------------------------------------------------------------------------+-- | Module interface.+data Interface ta sa+        = Interface+        { -- | Path that the interface was loaded from.+          interfaceFilePath     :: FilePath++          -- | Last modification time of the interface file,+          --   used to determine when the source needs to be rebuilt.+        , interfaceTimeStamp    :: UTCTime++        , interfaceVersion      :: String+        , interfaceModuleName   :: ModuleName+        , interfaceTetraModule  :: Maybe (Module ta Tetra.Name)+        , interfaceSaltModule   :: Maybe (Module sa Salt.Name) }+++---------------------------------------------------------------------------------------------------+instance Pretty (Interface ta sa) where+ ppr i+  =     (text "ddc interface" <+> text (interfaceVersion i))+         <> line <> line+         <> vcat [ text $ makeInterfaceTearLine "Meta"+                 , text "module-meta"   <+> lbrace <> line+                        <> indent 8 (vcat+                                [ hsep [text "name:", ppr $ interfaceModuleName i ] ])+                        <> line <> rbrace]++        -- Include the full unoptimised core code in interface files.+        --   We include the unoptimised code so that the modules that inline+        --   functions from this one are not sensitive to the optimisation flags+        --   use here. If we included the optimised code it would make it harder+        --   to reason about the overall compilation process.+        <> (case interfaceTetraModule i of+                Just m  -> vcat [ line +                                , text $ makeInterfaceTearLine "Tetra"+                                , ppr m ]+                Nothing -> empty)++        -- Include the header of the Salt module.+        --   We don't need the function definitions because inlining is performed+        --   using the higher level Tetra code.+        <> (case interfaceSaltModule i of+                Just m  -> +                 -- zap the module body so we don't get the function definitions.+                 let m' = m { moduleBody = xUnit (annotOfExp $ moduleBody m) }+                 in  vcat [ line+                          , text $ makeInterfaceTearLine "Salt"+                          , ppr m' ]+                Nothing -> empty)+++---------------------------------------------------------------------------------------------------+-- | Tear line to separate sections of the interface file. +--   We use '~' because it's not used in the core language syntax.+makeInterfaceTearLine :: String -> String+makeInterfaceTearLine name+        = "~~ " ++ name ++ " " ++ replicate (80 - 4 - length name) '~'++-- | Take the name from an interface tear line, if it is one.+takeInterfaceTearLine  :: String -> Maybe String+takeInterfaceTearLine str+        | '~' : '~' : ' ' : str2  <- str+        , (name, str3)            <- span (not . Char.isSpace) str2+        , (' ' : rest)            <- str3+        , all (== '~') rest+        = Just name++        | otherwise+        = Nothing++-- | Check if this string is an interface tear line.+isInterfaceTearLine :: String -> Bool+isInterfaceTearLine str+        = isJust $ takeInterfaceTearLine str+

@@ -0,0 +1,285 @@++-- | Loader for DDC interface files.+module DDC.Build.Interface.Load+        ( loadInterface+        , Error (..)+        , InterfaceAA)+where+import DDC.Build.Interface.Base+import DDC.Core.Check                           (AnTEC)+import DDC.Core.Module+import DDC.Base.Pretty+import DDC.Core.Transform.Reannotate+import Data.Time.Clock+import Control.Monad+import qualified DDC.Core.Load                  as Load+import qualified DDC.Core.Tetra                 as Tetra+import qualified DDC.Build.Language.Tetra       as Tetra+import qualified DDC.Core.Salt                  as Salt+import qualified DDC.Build.Language.Salt        as Salt+import qualified DDC.Data.SourcePos             as BP+import qualified Data.Char                      as Char+import qualified Data.List                      as List+++---------------------------------------------------------------------------------------------------+-- | Problems that can arise when loading an interface file.+data Error+        -- | Empty Interface file.+        = ErrorEmpty++        -- | No module meta information.+        | ErrorNoMeta++        -- | Duplicate module information.+        | ErrorDuplicate++        -- | Bad magic numbers / header information in alleged interface file.+        --   This probably isn't an interface file.+        | ErrorBadMagic+        { errorFilePath :: FilePath +        , errorLine     :: Int }++        -- | Parse error in Interface file.+        | ErrorParse+        { errorFilePath :: FilePath+        , errorLine     :: Int}++        -- | Parser error at end of input.+        | ErrorParseEnd++        -- | Error when loading a tetra core module from the interface file.+        | ErrorLoadTetra (Load.Error Tetra.Name Tetra.Error)++        -- | Error when loading a salt  core module from the interface file.+        | ErrorLoadSalt  (Load.Error  Salt.Name  Salt.Error)+++instance Pretty Error where+ ppr ErrorEmpty+  = vcat [ text "Empty interface file." ]++ ppr ErrorNoMeta+  = vcat [ text "No metadata section in interface file." ]++ ppr ErrorDuplicate+  = vcat [ text "Duplicate section in interface file." ]++ ppr (ErrorBadMagic path l)+  = vcat [ text path <> text ":" <> int l+         , text "Bad header in interface file." ]++ ppr (ErrorParse path l)+  = vcat [ text path <> text ":" <> int l+         , text "Parse error in interface file." ]++ ppr ErrorParseEnd+  = vcat [ text "Parse error at end of interface file." ]++ ppr (ErrorLoadTetra err)+  = vcat [ text "Error when loading Tetra module from interface file."+         , indent 2 $ ppr err ]++ ppr (ErrorLoadSalt err)+  = vcat [ text "Error when loading Salt module from interface file."+         , indent 2 $ ppr err ]+++---------------------------------------------------------------------------------------------------+-- | Line numbers.+type LineNumber  = Int++-- | Parser for some thing.+type Parser a    +        =  [(LineNumber, String)]+        -> Either Error a++-- | Type of annotated interface.+--   As don't store full Salt code in interface files,+--   we just set the annotation for it to ()+type InterfaceAA +        = Interface (AnTEC BP.SourcePos Tetra.Name) ()+++---------------------------------------------------------------------------------------------------+-- | Load an interface file.+loadInterface +        :: FilePath     -- ^ File path of interface file, for error messages.+        -> UTCTime      -- ^ TimeStamp of interface file.+        -> String       -- ^ Interface file source.+        -> Either Error InterfaceAA++loadInterface pathInterface timeStamp str+ = let  -- Attach line numbers to ach line+        ls      = lines str+        lsNum   = zip [1..] ls+   in   pInterface pathInterface timeStamp lsNum+++-- | Parse an interface file.+pInterface +        :: FilePath             -- ^ Path of interface file.+        -> UTCTime              -- ^ TimeStamp of interface file.+        -> Parser InterfaceAA++pInterface _pathInt _timeStamp []+        = Left ErrorEmpty++pInterface pathInt timeStamp ((n, str) : rest)+        -- Skip over blank lines+        | all (\c -> Char.isSpace c || c == '\n') str+        = pInterface pathInt timeStamp rest++        -- The interface needs to start with the magic words and version number.+        | ["ddc", "interface", version] <- words str+        = do    cs              <- pComponents pathInt rest++                -- We need exactly one module meta-data component.+                modName <- case [m | m@ComponentMeta{} <- cs] of+                                [m]     -> return $ componentModuleName m+                                _       -> Left $ ErrorNoMeta++                -- Accept a tetra module in the interface file.+                mTetra  <- case [m | m@ComponentTetraModule{} <- cs] of+                                []      -> return Nothing+                                [m]     -> return $ Just $ componentTetraModule m+                                _       -> Left ErrorDuplicate++                -- Accept a salt module in the interface file.+                mSalt   <- case [m | m@ComponentSaltModule{}  <- cs] of+                                []      -> return Nothing+                                [m]     -> return $ Just $ componentSaltModule m+                                _       -> Left ErrorDuplicate++                return  $ Interface+                        { interfaceFilePath     = pathInt+                        , interfaceTimeStamp    = timeStamp+                        , interfaceVersion      = version+                        , interfaceModuleName   = modName+                        , interfaceTetraModule  = mTetra+                        , interfaceSaltModule   = liftM (reannotate (const ())) mSalt }++        | otherwise+        = Left $ ErrorBadMagic pathInt n+++---------------------------------------------------------------------------------------------------+-- | A component of the interface file. +--   We use this as an intermediate form during parsing.+data Component+        = ComponentMeta+        { componentModuleName   :: ModuleName}++        | ComponentTetraModule+        { componentTetraModule  :: Module (AnTEC BP.SourcePos Tetra.Name) Tetra.Name }++        | ComponentSaltModule+        { componentSaltModule   :: Module (AnTEC BP.SourcePos Salt.Name)  Salt.Name  }+        deriving Show+++---------------------------------------------------------------------------------------------------+-- | Parse some components of an interface file.+pComponents :: FilePath -> Parser [Component]+pComponents _ []+        = return []++pComponents pathInterface (l : ls)+        -- skip blank lines+        | all Char.isSpace (snd l)+        = pComponents pathInterface ls++        -- parse a single section+        | isInterfaceTearLine (snd l)+        = do   let (ls', rest) = List.break (isInterfaceTearLine . snd) ls+               c       <- pComponent  pathInterface (l : ls')+               cs      <- pComponents pathInterface rest+               return  $ c : cs++        | otherwise+        = Left $ ErrorParse pathInterface (fst l)+++---------------------------------------------------------------------------------------------------+-- | Parse a single component of an interface file.+pComponent :: FilePath -> Parser Component+pComponent _ []   + = Left $ ErrorParseEnd++pComponent pathInt ((n, l) : rest)+        -- skip blank lines+        | all Char.isSpace l+        = pComponent pathInt rest++        -- load a module meta-data section.+        | Just "Meta"  <- takeInterfaceTearLine l+        = pComponentMeta pathInt rest++        -- load a Tetra core module section.+        | Just "Tetra" <- takeInterfaceTearLine l+        = case Load.loadModuleFromString Tetra.fragment pathInt (n + 1)+                       Load.Recon (unlines $ map snd rest) of+                (Left err, _)   -> Left $ ErrorLoadTetra  err+                (Right m,  _)   -> return $ ComponentTetraModule m++        -- load a Salt core module section.+        | Just "Salt"  <- takeInterfaceTearLine l+        = case Load.loadModuleFromString Salt.fragment pathInt (n + 1)+                       Load.Recon (unlines $ map snd rest) of+               (Left err, _)   -> Left $ ErrorLoadSalt err +               (Right m,  _)   -> return $ ComponentSaltModule  m++        -- this thing didn't parse.+        | otherwise+        = Left $ ErrorParse pathInt n+++---------------------------------------------------------------------------------------------------+-- | Parse module meta data from an interface file.+pComponentMeta :: FilePath -> Parser Component+pComponentMeta _pathInt [] +        = Left ErrorParseEnd++pComponentMeta pathInt nls@((n, _) : _)+        | "module-meta" : "{" : "name:" : strModName : "}" : []+                <- tokenize $ concatMap snd nls+        , Just modName     <- moduleNameOfString strModName+        = return $ ComponentMeta +                 { componentModuleName   = modName }++        | otherwise+        = Left   $ ErrorParse pathInt n+++---------------------------------------------------------------------------------------------------+-- | Tokenise the interface header containing module meta data.+tokenize :: String -> [String]+tokenize str+ = go [] str+ where  go acc []         = pop acc []++        go acc (c : cs)+         | Char.isSpace c = pop acc (go [] cs)+         | c == '{'       = pop acc ("{" : go [] cs)+         | c == '}'       = pop acc ("}" : go [] cs)+         | otherwise      = go (c : acc) cs++        pop acc x+         = case acc of+                []      -> x+                _       -> reverse acc : x+++-- | Parse a String as a `ModuleName`, or Nothing if it isn't one.+moduleNameOfString :: String -> Maybe ModuleName+moduleNameOfString str+ = Just $ ModuleName $ go str+ where+        go s+         | elem '.' s+         , (n, '.' : rest) <- span (/= '.') s+         = n : go rest++         | otherwise+         = [s]+

@@ -0,0 +1,256 @@++module DDC.Build.Interface.Store+        ( Store+        , new, wrap, load++        , Meta  (..)+        , getMeta+        , getModuleNames+        , getInterfaces++        , Super (..)+        , findSuper)+where+import DDC.Base.Pretty+import DDC.Build.Interface.Base         +import DDC.Build.Interface.Load+import DDC.Core.Call+import DDC.Core.Module+import DDC.Type.Exp+import System.Directory+import Data.Time.Clock+import Data.IORef+import Data.Maybe+import Data.Map                         (Map)+import qualified DDC.Core.Tetra         as E+import qualified DDC.Core.Salt          as A+import qualified Data.Map               as Map+++---------------------------------------------------------------------------------------------------+-- | Abstract API to a collection of module interfaces.+--+--   This lives in IO land because in future we want to demand-load the+--   inferface files as needed, rather than loading the full dependency+--   tree. Keeping it in IO means that callers must also be in IO.+data Store+        = Store+        { -- | Metadata for interface files currently in the store.+          storeMeta       :: IORef [Meta]++          -- | Lookup the definition of the given top-level super, +          --   from one or more of the provided modules.+        , storeSupers     :: IORef (Map ModuleName (Map E.Name Super)) ++          -- | Fully loaded interface files.+          --   In future we want to load parts of interface files on demand, +          --   and not the whole lot.+        , storeInterfaces :: IORef [InterfaceAA] }+++---------------------------------------------------------------------------------------------------+-- | Metadata for interfaces currently loaded into the store.+data Meta+        = Meta+        { metaFilePath     :: FilePath+        , metaTimeStamp    :: UTCTime+        , metaModuleName   :: ModuleName }+        deriving Show++instance Pretty Meta where+        ppr (Meta path stamp name)+         = hsep [ padL 60 $ text (show path)+                , padL 30 $ text (show stamp)+                , text (show name)]+++-- | Interface for some top-level super.+data Super+        = Super+        { -- | Name of the super.+          superName             :: E.Name++          -- | Where the super was imported from.+          --+          --   This is the module that the name was resolved from. If that+          --   module re-exported an imported name then this may not be the+          --   module the super was actually defined in.+        , superModuleName       :: ModuleName++          -- | Tetra type for the super.+        , superTetraType        :: Type E.Name++          -- | Salt type for the super.+        , superSaltType         :: Type A.Name ++          -- | Import source for the super.+          --+          --   This can be used to refer to the super from a client module.+        , superImportValue      :: ImportValue E.Name }+++---------------------------------------------------------------------------------------------------+-- | An empty interface store.+new :: IO Store+new+ = do   refMeta         <- newIORef []+        refSupers       <- newIORef Map.empty+        refInterfaces   <- newIORef []+        return  $ Store +                { storeMeta             = refMeta+                , storeSupers           = refSupers +                , storeInterfaces       = refInterfaces }+++-- | Add a pre-loaded interface file to the store.+wrap    :: Store -> InterfaceAA -> IO ()+wrap store ii+ = do   modifyIORef (storeMeta store)+         $ \meta   -> meta ++ [metaOfInterface ii] ++        modifyIORef (storeSupers store)+         $ \supers -> Map.insert (interfaceModuleName ii)+                                 (supersOfInterface   ii)+                                 supers++        modifyIORef (storeInterfaces store)+         $ \iis    -> iis ++ [ii]+++-- | Load a new interface from a file.+load    :: FilePath -> IO (Either Error InterfaceAA)+load filePath+ = do   timeStamp  <- getModificationTime filePath+        str        <- readFile filePath+        return $ loadInterface filePath timeStamp str+++-- | Get metadata of interfaces currently in the store.+getMeta :: Store -> IO [Meta]+getMeta store+ = do   mm      <- readIORef (storeMeta store)+        return  $ mm+++-- | Get names of the modules currently in the store.+getModuleNames :: Store -> IO [ModuleName]+getModuleNames store+ = do   supers  <- readIORef (storeSupers store)+        return  $ Map.keys supers+++-- | Get the fully loaded interfaces.+getInterfaces :: Store -> IO [InterfaceAA]+getInterfaces store+ = do   ints    <- readIORef (storeInterfaces store)+        return ints+++-- | See if a super is defined in any of the given modules, and if so+--   return the module name and super type.+--+--   NOTE: This function returns an IO [Super] in preparation for the case+--   where we load data from interface files on demand. We want to ensure+--   that the caller is also in IO, to make the refactoring easier later.+--+findSuper+        :: Store+        -> E.Name               -- ^ Name of desired super.+        -> [ModuleName]         -- ^ Names of modules to search.+        -> IO [Super]++findSuper store n modNames + = do   supers  <- readIORef (storeSupers store)+        return $ mapMaybe+                (\modName -> do+                        nSupers <- Map.lookup modName supers+                        Map.lookup n nSupers)+                modNames+++---------------------------------------------------------------------------------------------------+-- | Extract metadata from an interface.+metaOfInterface   :: InterfaceAA -> Meta+metaOfInterface ii+        = Meta+        { metaFilePath   = interfaceFilePath   ii+        , metaTimeStamp  = interfaceTimeStamp  ii+        , metaModuleName = interfaceModuleName ii }+++-- | Extract a map of super interfaces from the given module interface.+--+--   This contains all the information needed to import a super into+--   a client module.+--+supersOfInterface :: InterfaceAA -> Map E.Name Super+supersOfInterface ii+ | Just mmTetra <- interfaceTetraModule ii+ , Just mmSalt  <- interfaceSaltModule  ii+ = let  +        -- The current module name.+        modName = interfaceModuleName ii++        -- Collect Tetra types for all supers exported by the module.+        ntsTetra    +         = Map.fromList+           [ (n, t)     | (n, esrc)     <- moduleExportValues mmTetra+                        , let Just t    =  takeTypeOfExportSource esrc ]++        -- Collect Salt  types of all supers exported by the module.+        ntsSalt +         = Map.fromList+           [ (n, t)     | (n, esrc)     <- moduleExportValues mmSalt+                        , let Just t    =  takeTypeOfExportSource esrc ]++        -- Build call patterns for all locally defined supers.+        --  The call pattern is the number of type parameters then value parameters+        --  for the super. We assume all supers are in prenex form, so they take+        --  all their type arguments before their value arguments.+        makeLocalArity b x+         | BName nSuper _       <- b+         , cs                   <- takeCallConsFromExp x+         , Just (csType, csValue, csBox) <- splitStdCallCons cs+         = (nSuper, (length csType, length csValue, length csBox))++         | otherwise = error "ddc-build.supersOfInterface: type is not in prenex form."++        nsLocalArities :: Map E.Name (Int, Int, Int)+                =  Map.fromList+                $  mapTopBinds makeLocalArity+                $  mmTetra++        -- Build an ImportSource for the given super name. A client module+        -- can use this to import the super into itself.+        makeImportValue n++         -- Super was defined as a top-level binding in the current module.+         | Just (aType, aValue, nBoxes) <- Map.lookup n nsLocalArities+         , Just tTetra                  <- Map.lookup n ntsTetra+         = ImportValueModule modName n tTetra (Just (aType, aValue, nBoxes))++         -- Super was imported into the current module from somewhere else.+         -- Pass along the same import declaration to the client.+         | Just impt            <- lookup n (moduleImportValues mmTetra)+         = impt++         | otherwise = error $ "ddc-build.supersOfInterface: no source" ++ show n++        makeSuper n tTetra+         | E.NameVar s  <- n+         = Just $ Super+                { superName         = n+                , superModuleName   = moduleName mmTetra+                , superTetraType    = tTetra+                , superSaltType     = let Just t = Map.lookup (A.NameVar s) ntsSalt  in t +                , superImportValue  = makeImportValue n }+         | otherwise    = Nothing+++   in   Map.fromList   +          [ (n, super)  | (n, tTetra)    <- Map.toList ntsTetra +                        , let Just super = makeSuper n tTetra ]++ | otherwise+ = Map.empty+

@@ -8,9 +8,7 @@ where import DDC.Core.Fragment import DDC.Build.Language.Base-import DDC.Build.Language.Lite  as Lite import DDC.Build.Language.Salt  as Salt-import DDC.Build.Language.Eval  as Eval import DDC.Build.Language.Flow  as Flow import DDC.Build.Language.Zero  as Zero import DDC.Build.Language.Tetra as Tetra@@ -18,19 +16,17 @@  -- | Supported language profiles. --   ---   One of @Tetra@, @Lite@, @Salt@, @Eval@, @Flow@, @Zero@.+--   One of @Tetra@, @Salt@, @Eval@, @Flow@, @Zero@. languages :: [(String, Language)] languages  =      [ ( "Tetra", Tetra.language) -        , ( "Lite",  Lite.language)         , ( "Salt",  Salt.language)-        , ( "Eval",  Eval.language)         , ( "Flow",  Flow.language)         , ( "Zero",  Zero.language) ]   -- | Return the language fragment definition corresponding to the given ---   file extension. eg @dcl@ gives the definition of the Lite language.+--   file extension. eg @dct@ gives the definition of the Tetra language. languageOfExtension :: String -> Maybe Language languageOfExtension ext  = let  -- Strip of dots at the front.@@ -41,9 +37,7 @@                         _               -> ext    in case ext' of         "dct"   -> Just Tetra.language-        "dcl"   -> Just Lite.language         "dcs"   -> Just Salt.language-        "dcv"   -> Just Eval.language         "dcf"   -> Just Flow.language         "dcz"   -> Just Zero.language         _       -> Nothing

@@ -10,6 +10,7 @@ import DDC.Core.Transform.Namify import DDC.Core.Transform.Rewrite import DDC.Base.Pretty+import DDC.Base.Name import Control.DeepSeq import Data.Typeable import Data.Map                         (Map)@@ -27,7 +28,8 @@           , Pretty n           , Pretty (err (AnTEC BP.SourcePos n))           , Pretty (err (AnTEC () n))-          , NFData n)+          , NFData n+          , CompoundName n)         => Language (Bundle s n err)  

@@ -1,75 +0,0 @@---- | The `Eval` fragment can be interpreted with our semantic interpreter.-module DDC.Build.Language.Eval-        ( language-        , bundle-        , fragment-        , profile)-where-import DDC.Build.Language.Base-import DDC.Core.Simplifier-import DDC.Core.Transform.Namify-import DDC.Core.Eval.Profile-import DDC.Core.Eval.Name-import DDC.Core.Fragment-import DDC.Core.Eval.Check              as Eval-import DDC.Type.Exp-import DDC.Type.Env                     (Env)-import qualified DDC.Type.Env           as Env-import qualified Data.Map               as Map-import Control.Monad.State.Strict----- | Language definition for Disciple Core Eval.-language    :: Language-language    = Language bundle----- | Language bundle for Disciple Core Eval.-bundle      :: Bundle Int Name Eval.Error-bundle  = Bundle-        { bundleFragment        = fragment-        , bundleModules         = Map.empty-        , bundleStateInit       = 0 :: Int-        , bundleSimplifier      = Trans Id-        , bundleMakeNamifierT   = makeNamifier freshT-        , bundleMakeNamifierX   = makeNamifier freshX-        , bundleRewriteRules    = Map.empty }----- | Fragment definition for Disciple Core Eval.-fragment :: Fragment Name Eval.Error-fragment-        = Fragment-        { fragmentProfile       = evalProfile-        , fragmentExtension     = "dcv"-        , fragmentReadName      = readName-        , fragmentLexModule     = lexModuleString-        , fragmentLexExp        = lexExpString-        , fragmentCheckModule   = checkCapsModule-        , fragmentCheckExp      = checkCapsX  }---profile = evalProfile---- | Create a new type variable name that is not in the given environment.-freshT :: Env Name -> Bind Name -> State Int Name-freshT env bb- = do   i       <- get-        put (i + 1)-        let n =  NameVar ("t" ++ show i)-        case Env.lookupName n env of-         Nothing -> return n-         _       -> freshT env bb----- | Create a new value variable name that is not in the given environment.-freshX :: Env Name -> Bind Name -> State Int Name-freshX env bb- = do   i       <- get-        put (i + 1)-        let n = NameVar ("v" ++ show i)-        case Env.lookupName n env of-         Nothing -> return n-         _       -> freshX env bb-

@@ -18,15 +18,14 @@ import qualified Data.Map               as Map  --- | Language definition for Disciple Core Lite.+-- | Language definition for Disciple Core Flow. language    :: Language language    = Language bundle  --- | Language bundle for Disciple Core Lite.+-- | Language bundle for Disciple Core Flow. bundle  :: Bundle Int Name Error-bundle-        = Bundle+bundle  = Bundle         { bundleFragment        = fragment         , bundleModules         = Map.empty         , bundleStateInit       = 0 :: Int@@ -36,7 +35,7 @@         , bundleRewriteRules    = Map.empty }  --- | Fragement definition for Disciple Core Lite.+-- | Fragement definition for Disciple Core Flow. fragment :: Fragment Name Error fragment         = Fragment

@@ -1,73 +0,0 @@---- | The `Lite` fragment is a desugared version of Disciple Core that has all---   the polymorphism of System-F2 along with algebraic data types.-module DDC.Build.Language.Lite-        ( language-        , bundle-        , fragment-        , freshT-        , freshX)-where-import DDC.Build.Language.Base-import DDC.Core.Simplifier-import DDC.Core.Transform.Namify-import DDC.Core.Fragment-import DDC.Core.Lite                    as Lite-import DDC.Type.Exp-import DDC.Type.Env                     (Env)-import qualified DDC.Type.Env           as Env-import qualified Data.Map               as Map-import Control.Monad.State.Strict----- | Language definition for Disciple Core Lite.-language    :: Language-language    = Language bundle----- | Language bundle for Disciple Core Lite.-bundle  :: Bundle Int Name Lite.Error-bundle-        = Bundle-        { bundleFragment        = fragment-        , bundleModules         = Map.empty-        , bundleStateInit       = 0 :: Int-        , bundleSimplifier      = Trans Id-        , bundleMakeNamifierT   = makeNamifier freshT -        , bundleMakeNamifierX   = makeNamifier freshX -        , bundleRewriteRules    = Map.empty }----- | Fragement definition for Disciple Core Lite.-fragment :: Fragment Name Lite.Error-fragment-        = Fragment-        { fragmentProfile       = profile -        , fragmentExtension     = "dcl"-        , fragmentReadName      = readName-        , fragmentLexModule     = lexModuleString-        , fragmentLexExp        = lexExpString-        , fragmentCheckModule   = const Nothing-        , fragmentCheckExp      = const Nothing }----- | Create a new type variable name that is not in the given environment.-freshT :: Env Name -> Bind Name -> State Int Name-freshT env bb- = do   i       <- get-        put (i + 1)-        let n =  NameVar ("t" ++ show i)-        case Env.lookupName n env of-         Nothing -> return n-         _       -> freshT env bb----- | Create a new value variable name that is not in the given environment.-freshX :: Env Name -> Bind Name -> State Int Name-freshX env bb- = do   i       <- get-        put (i + 1)-        let n = NameVar ("x" ++ show i)-        case Env.lookupName n env of-         Nothing -> return n-         _       -> freshX env bb

@@ -12,9 +12,9 @@ import DDC.Core.Simplifier import DDC.Core.Transform.Namify import DDC.Core.Fragment-import DDC.Core.Salt                    as Salt import DDC.Type.Exp import DDC.Type.Env                     (Env)+import qualified DDC.Core.Salt          as A import qualified DDC.Type.Env           as Env import qualified Data.Map               as Map import Control.Monad.State.Strict@@ -26,7 +26,7 @@   -- | Language bundle for Disciple Core Salt.-bundle   :: Bundle Int Name Salt.Error+bundle   :: Bundle Int A.Name A.Error bundle  = Bundle         { bundleFragment        = fragment         , bundleModules         = Map.empty@@ -38,35 +38,35 @@   -- | Fragment definition for Disciple Core Salt.-fragment :: Fragment Name Salt.Error+fragment :: Fragment A.Name A.Error fragment          = Fragment-        { fragmentProfile       = profile +        { fragmentProfile       = A.profile          , fragmentExtension     = "dcs"-        , fragmentReadName      = readName-        , fragmentLexModule     = lexModuleString-        , fragmentLexExp        = lexExpString+        , fragmentReadName      = A.readName+        , fragmentLexModule     = A.lexModuleString+        , fragmentLexExp        = A.lexExpString         , fragmentCheckModule   = const Nothing         , fragmentCheckExp      = const Nothing }   -- | Create a new type variable name that is not in the given environment.-freshT :: Env Name -> Bind Name -> State Int Name+freshT :: Env A.Name -> Bind A.Name -> State Int A.Name freshT env bb  = do   i       <- get         put (i + 1)-        let n =  NameVar ("t" ++ show i)+        let n =  A.NameVar ("t" ++ show i)         case Env.lookupName n env of          Nothing -> return n          _       -> freshT env bb   -- | Create a new value variable name that is not in the given environment.-freshX :: Env Name -> Bind Name -> State Int Name+freshX :: Env A.Name -> Bind A.Name -> State Int A.Name freshX env bb  = do   i       <- get         put (i + 1)-        let n = NameVar ("x" ++ show i)+        let n = A.NameVar ("x" ++ show i)         case Env.lookupName n env of          Nothing -> return n          _       -> freshX env bb

@@ -44,4 +44,3 @@         , fragmentLexExp        = E.lexExpString         , fragmentCheckModule   = E.checkModule         , fragmentCheckExp      = const Nothing }-

@@ -13,6 +13,7 @@ import DDC.Core.Fragment                hiding (Error) import DDC.Core.Transform.Namify import DDC.Base.Pretty+import DDC.Base.Name import DDC.Data.Token import DDC.Type.Exp import Data.Typeable@@ -65,16 +66,31 @@ -- Wrap the names we use for the zero fragment,  -- so they get pretty printed properly. data Name -        = Name String+        = Name    String+        | NameExt Name String         deriving (Eq, Ord, Show, Typeable) + instance NFData Name where- rnf (Name str) = rnf str+ rnf (Name str)         = rnf str+ rnf (NameExt n str)    = rnf n `seq` rnf str + instance Pretty Name where- ppr (Name str) = text str+ ppr (Name str)         = text str+ ppr (NameExt n str)    = ppr n <> text "$" <> text str  +instance CompoundName Name where+ extendName n str       +  = NameExt n str+ + splitName nn+  = case nn of+        NameExt n str   -> Just (n, str)+        _               -> Nothing++ -- | Lex a string to tokens, using primitive names. -- --   The first argument gives the starting source line number.@@ -84,7 +100,7 @@  where rn (Token t sp)          = case renameTok (Just . Name) t of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp   -- | Lex a string to tokens, using primitive names.@@ -96,7 +112,7 @@  where rn (Token t sp)          = case renameTok (Just . Name) t of                 Just t' -> Token t' sp-                Nothing -> Token (KJunk "lexical error") sp+                Nothing -> Token (KErrorJunk "lexical error") sp   -- | Create a new type variable name that is not in the given environment.

@@ -21,10 +21,6 @@         , PipeTetra       (..)         , pipeTetra -          -- * Core Lite modules-        , PipeLite        (..)-        , pipeLite-           -- * Core Flow modules         , PipeFlow        (..)         , pipeFlow

@@ -7,9 +7,6 @@         , PipeTetra (..)         , pipeTetra -        , PipeLite (..)-        , pipeLite-         , PipeFlow (..)         , pipeFlow) where@@ -19,40 +16,46 @@ import DDC.Build.Language import DDC.Core.Simplifier import DDC.Base.Pretty+import DDC.Base.Name import DDC.Data.Canned import DDC.Llvm.Pretty                                  ()  import qualified DDC.Core.Flow                          as Flow import qualified DDC.Core.Flow.Profile                  as Flow-import qualified DDC.Core.Flow.Transform.Slurp          as Flow+import qualified DDC.Core.Flow.Transform.Forward        as Flow import qualified DDC.Core.Flow.Transform.Melt           as Flow import qualified DDC.Core.Flow.Transform.Wind           as Flow import qualified DDC.Core.Flow.Transform.Rates.SeriesOfVector as Flow+import qualified DDC.Core.Flow.Convert                  as Flow -import qualified DDC.Core.Tetra                         as Tetra+import qualified DDC.Core.Tetra.Transform.Curry         as Tetra import qualified DDC.Core.Tetra.Transform.Boxing        as Tetra+import qualified DDC.Core.Tetra                         as Tetra -import qualified DDC.Core.Lite                          as Lite+import qualified DDC.Core.Babel.PHP                     as PHP  import qualified DDC.Core.Salt.Platform                 as Salt import qualified DDC.Core.Salt.Runtime                  as Salt import qualified DDC.Core.Salt                          as Salt +import qualified DDC.Core.Transform.Unshare             as C import qualified DDC.Core.Transform.Reannotate          as C-import qualified DDC.Core.Transform.Deannotate          as C import qualified DDC.Core.Transform.Namify              as C-import qualified DDC.Core.Transform.Forward             as Forward import qualified DDC.Core.Transform.Snip                as Snip import qualified DDC.Core.Transform.Flatten             as Flatten import qualified DDC.Core.Transform.Eta                 as Eta+import qualified DDC.Core.Transform.Beta                as Beta+import qualified DDC.Core.Transform.Lambdas             as Lambdas+import qualified DDC.Core.Transform.Forward             as Forward import qualified DDC.Core.Simplifier                    as C  import qualified DDC.Core.Fragment                      as C import qualified DDC.Core.Check                         as C import qualified DDC.Core.Pretty                        as C import qualified DDC.Core.Module                        as C-import qualified DDC.Core.Exp                           as C +import qualified DDC.Core.Exp.Annot                     as C+ import qualified DDC.Type.Env                           as Env  import qualified Control.Monad.State.Strict             as S@@ -60,6 +63,7 @@ import Control.DeepSeq  +--------------------------------------------------------------------------------------------------- -- | Process a core module. data PipeCore a n where   -- Plumb the module on without transforming it.@@ -99,7 +103,8 @@    -- Apply a simplifier to a module.   PipeCoreSimplify  -        :: !(Fragment n err)+        :: (Pretty a, CompoundName n)+        => !(Fragment n err)         -> !s         -> !(Simplifier s a n)         -> ![PipeCore () n] @@ -107,21 +112,16 @@    -- Treat a module as belonging to the Core Tetra fragment from now on.   PipeCoreAsTetra-        :: ![PipeTetra (C.AnTEC a Tetra.Name)]-        -> PipeCore (C.AnTEC a Tetra.Name) Tetra.Name--  -- Treat a module as belonging to the Core Lite fragment from now on.-  PipeCoreAsLite-        :: ![PipeLite]-        -> PipeCore (C.AnTEC () Lite.Name) Lite.Name+        :: ![PipeTetra a]+        -> PipeCore a Tetra.Name -  -- Treat a module as beloning to the Core Flow fragment from now on.+  -- Treat a module as belonging to the Core Flow fragment from now on.   PipeCoreAsFlow          :: Pretty a         => ![PipeFlow a]         -> PipeCore a Flow.Name -  -- Treat a module as beloning to the Core Salt fragment from now on.+  -- Treat a module as belonging to the Core Salt fragment from now on.   PipeCoreAsSalt         :: Pretty a          => ![PipeSalt a] @@ -217,10 +217,6 @@          -> {-# SCC "PipeCoreAsTetra" #-}             liftM concat $ mapM (pipeTetra mm) pipes -        PipeCoreAsLite !pipes-         -> {-# SCC "PipeCoreAsLite" #-}-            liftM concat $ mapM (pipeLite mm) pipes-         PipeCoreAsFlow !pipes          -> {-# SCC "PipeCoreAsFlow" #-}             liftM concat $ mapM (pipeFlow mm) pipes@@ -248,7 +244,7 @@                 go (errs ++ err) rest  --- PipeTetra ------------------------------------------------------------------+-- PipeTetra -------------------------------------------------------------------------------------- -- | Process a Core Tetra module. data PipeTetra a where         -- Output the module in core language syntax.@@ -256,6 +252,12 @@          :: !Sink          -> PipeTetra a +        -- Manage currying of functions.+        PipeTetraCurry+         :: (NFData a, Show a)+         => ![PipeCore () Tetra.Name]+         -> PipeTetra  (C.AnTEC a Tetra.Name)+         -- Manage boxing of numeric values.         PipeTetraBoxing          :: (NFData a, Show a)@@ -270,7 +272,14 @@          -> ![PipeCore a Salt.Name]          -> PipeTetra  (C.AnTEC a Tetra.Name) +        -- Print as PHP code+        PipeTetraToPHP+         :: (NFData a, Show a)+         => !Sink+         -> PipeTetra a ++ -- | Process a Core Tetra module. pipeTetra          :: C.Module a Tetra.Name@@ -281,8 +290,14 @@  = case pp of         PipeTetraOutput !sink          -> {-# SCC "PipeTetraOutput" #-}-            pipeSink (renderIndent $ ppr mm) sink+            pipeSink (renderIndent $ ppr mm)  sink +        PipeTetraCurry  !pipes+         -> {-# SCC "PipeTetraCurry"  #-}+            case Tetra.curryModule (C.unshareModule mm) of+             Left err  -> return [ErrorTetraConvert err]+             Right mm' -> pipeCores mm' pipes+         PipeTetraBoxing !pipes          -> {-# SCC "PipeTetraBoxing" #-}             pipeCores (Tetra.boxingModule mm) pipes@@ -297,43 +312,22 @@              of  Left  err  -> return [ErrorTetraConvert err]                  Right mm'  -> pipeCores mm' pipes  ----- PipeLite ---------------------------------------------------------------------- | Process a Core Lite module.-data PipeLite-        -- | Output the module in core language syntax.-        = PipeLiteOutput !Sink--        -- | Convert the module to the Core Salt Fragment.-        | PipeLiteToSalt !Salt.Platform -                         !Salt.Config-                         ![PipeCore () Salt.Name]----- | Process a Core Lite module.-pipeLite :: C.Module (C.AnTEC () Lite.Name) Lite.Name-         -> PipeLite-         -> IO [Error]+        PipeTetraToPHP !sink+         -> {-# SCC "PipeTetraToPHP" #-}+            let -- Snip program to expose intermediate bindings.+                mm_snip         = Flatten.flatten +                                $ Snip.snip (Snip.configZero) mm -pipeLite !mm !pp- = case pp of-        PipeLiteOutput !sink-         -> {-# SCC "PipeLiteOutput" #-}-            pipeSink (renderIndent $ ppr mm) sink+                -- The floater needs bindings to be fully named.+                namifierT       = C.makeNamifier Tetra.freshT Env.empty+                namifierX       = C.makeNamifier Tetra.freshX Env.empty+                mm_namified     = S.evalState (C.namify namifierT namifierX mm_snip) 0 -        PipeLiteToSalt !platform !runConfig !pipes-         -> {-# SCC "PipeLiteToSalt" #-}-            case Lite.saltOfLiteModule platform runConfig -                        (C.profilePrimDataDefs Lite.profile) -                        (C.profilePrimKinds    Lite.profile)-                        (C.profilePrimTypes    Lite.profile)-                        mm -             of  Left  err  -> return [ErrorLiteConvert err]-                 Right mm'  -> pipeCores mm' pipes +                doc  = PHP.phpOfModule mm_namified+            in  pipeSink (renderIndent doc) sink  --- PipeFlow -------------------------------------------------------------------+-- PipeFlow --------------------------------------------------------------------------------------- -- | Process a Core Flow module. data PipeFlow a where   -- Output the module in core language syntax.@@ -378,7 +372,12 @@         :: [PipeCore () Flow.Name]         -> PipeFlow (C.AnTEC () Flow.Name) +  -- Wind loop# primops into tail recursive loops.+  PipeFlowToTetra+        :: [PipeCore () Salt.Name]+        -> PipeFlow (C.AnTEC () Flow.Name) + -- | Process a Core Flow module. pipeFlow :: C.Module a Flow.Name          -> PipeFlow a@@ -416,16 +415,7 @@                  -- Float worker functions and initializers into their use sites,                  -- leaving only flow operators at the top-level.-                isFloatable lts-                 = case lts of-                    C.LLet (C.BName _ _) x-                      |  Flow.isSeriesOperator (C.deannotate (const Nothing) x)-                      -> Forward.FloatDeny-                    _ -> Forward.FloatForce--                mm_float        = C.result $ Forward.forwardModule Flow.profile -                                        (Forward.Config isFloatable False)-                                        mm_namified+                mm_float        = Flow.forwardProcesses mm_namified              in  pipeCores mm_float pipes @@ -448,20 +438,26 @@                 namifierX       = C.makeNamifier Flow.freshX Env.empty                 mm_namified     = S.evalState (C.namify namifierT namifierX mm_snip) 0 -                -- Float worker functions and initializers into their use sites, -                -- leaving only flow operators at the top-level.-                isFloatable lts-                 = case lts of-                    C.LLet (C.BName _ _) x-                      |  Flow.isVectorOperator (C.deannotate (const Nothing) x)-                      -> Forward.FloatDeny-                    _ -> Forward.FloatForce -                mm_float        = C.result $ Forward.forwardModule Flow.profile -                                        (Forward.Config isFloatable False)-                                        mm_namified+                floatControl l+                 = case l of+                   C.LLet _ x+                     | Just _ <- C.takeXLamFlags x+                     -> Forward.FloatForceUsedOnce+                   _ -> Forward.FloatDeny +                -- Force forward all worker functions.+                -- Anything that's not a vector op will be treated as an external,+                -- so that's fine.+                mm_float        = C.result+                                $ Forward.forwardModule Flow.profile+                                    (Forward.Config floatControl False)+                                    $ C.reannotate (const ()) mm_namified+++                 goRate+                 -- Rate inference uses the types                  = case C.checkModule (C.configOfProfile Flow.profile) mm_float C.Recon of                      (Left err, _)                           -> return [ErrorCoreTransform err]@@ -470,8 +466,8 @@                       -> let mm_stripped = C.reannotate (const ()) mm'                              mm_flow     = fst $ Flow.seriesOfVectorModule mm_stripped                            -                             -- Check again to synthesise types-                         in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Recon of+                            -- Synthesise the types of any newly created bindings.+                         in case C.checkModule (C.configOfProfile Flow.profile) mm_flow C.Synth of                              (Left err, _ct)                                        -> return [ErrorCoreTransform err]                             @@ -500,6 +496,59 @@             let mm_stripped     = C.reannotate (const ()) mm                 mm_wound        = Flow.windModule mm_stripped             in  pipeCores mm_wound pipes++        PipeFlowToTetra !pipes+         -> {-# SCC "PipeFlowToTetra" #-}+            let +                -- Apply any lambdas we can+                mm_beta         = C.result $ Beta.betaReduce Flow.profile+                                        (Beta.configZero { Beta.configBindRedexes = True})+                                        mm++                -- Eta-expand all the leftovers so they can be lifted+                mm_eta          = C.result $ Eta.etaModule   Flow.profile+                                        (Eta.configZero { Eta.configExpand = True})+                                        mm_beta+++                -- Lift up any remaining lambdas+                mm_lift         = Lambdas.lambdasModule Flow.profile mm_eta++                -- Snip program so arguments and case scrutinees are just variables+                mm_snip         = Flatten.flatten +                                $ Snip.snip +                                        Snip.configZero+                                        mm_lift++                -- The floater needs bindings to be fully named.+                namifierT       = C.makeNamifier Flow.freshT Env.empty+                namifierX       = C.makeNamifier Flow.freshX Env.empty+                mm_namified     = S.evalState (C.namify namifierT namifierX mm_snip) 0++            in  case Flow.tetraOfFlowModule mm_namified of+                 Left  err  -> return [ErrorFlowConvert err]+                 Right mm'  ->+                  case C.checkModule (C.configOfProfile Salt.profile) mm' C.Recon of+                   (Left err, _ct)         +                    -> return [ErrorCoreTransform err]+                   (Right mm_check', _ct) +                    -> let mm_reannot' = C.reannotate (const ()) mm_check'++                           floatControl l+                             = case l of+                               C.LLet b _+                                 | Just _ <- C.takeTFun $ C.typeOfBind b+                                 -> Forward.FloatForce+                               _ -> Forward.FloatAllow++                           -- Forward all functions+                           mm_float        = C.result+                                           $ Forward.forwardModule Salt.profile+                                               (Forward.Config floatControl True)+                                               $ C.reannotate (const ()) mm_reannot'++                       in  pipeCores mm_float pipes+   -- | Process a Flow module with several different pipes.

@@ -27,8 +27,8 @@         -- | Error converting the module from Tetra to Salt.         | forall err. Pretty err => ErrorTetraConvert !err -        -- | Error converting the module from Lite to Salt.-        | forall err. Pretty err => ErrorLiteConvert !err+        -- | Error converting the module from Tetra to Salt.+        | forall err. Pretty err => ErrorFlowConvert  !err          -- | Error when transforming core program.         | forall err. Pretty err => ErrorCoreTransform !err@@ -51,15 +51,15 @@                  , indent 2 (ppr err') ]          ErrorSaltConvert err'-         -> vcat [ text "Fragment violation when converting Salt module to C code."+         -> vcat [ text "Fragment violation when converting Salt module to target code."                  , indent 2 (ppr err') ]          ErrorTetraConvert err'          -> vcat [ text "Fragment violation when converting Tetra module to Salt module."                  , indent 2 (ppr err') ] -        ErrorLiteConvert err'-         -> vcat [ text "Fragment violation when converting Lite module to Salt module."+        ErrorFlowConvert err'+         -> vcat [ text "Fragment violation when converting Flow module to Tetra module."                  , indent 2 (ppr err') ]          ErrorCoreTransform err'@@ -67,5 +67,6 @@                  , indent 2 (ppr err') ]  -instance NFData Error+instance NFData Error where+ rnf !_ = () 

@@ -22,7 +22,8 @@         , pipeFileLlvm          :: FilePath         , pipeFileAsm           :: FilePath         , pipeFileObject        :: FilePath-        , pipeFileExe           :: Maybe FilePath +        , pipeFileExe           :: Maybe FilePath+        , pipeLinkOtherObjects  :: [FilePath]         , pipeKeepLlvmFiles     :: Bool          , pipeKeepAsmFiles      :: Bool }         deriving (Show)@@ -43,7 +44,7 @@             pipeSink (renderIndent $ ppr mm) sink          PipeLlvmCompile -                !builder !llPath !sPath !oPath !mExePath+                !builder !llPath !sPath !oPath !mExePath !osLinkOther                 !keepLlvmFiles !keepAsmFiles          -> {-# SCC "PipeLlvmCompile" #-}             do  -- Write out the LLVM source file.@@ -62,7 +63,7 @@                    -> return ()                    Just exePath-                   -> do buildLdExe builder oPath exePath+                   -> do buildLdExe builder (oPath : osLinkOther) exePath                          return ())                  -- Remove LLVM IR files if we weren't asked for them.

@@ -101,9 +101,11 @@         PipeSaltToLlvm !platform !more          -> {-# SCC "PipeSaltToLlvm" #-}             do  let !mm_cut  = C.reannotate (const ()) mm-                let !mm'     = Llvm.convertModule platform mm_cut -                results <- mapM (pipeLlvm mm') more-                return  $ concat results+                case Llvm.convertModule platform mm_cut of+                 Left err       -> return [ErrorSaltConvert err]+                 Right mm'      +                  -> do results <- mapM (pipeLlvm mm') more+                        return $ concat results          PipeSaltCompile                  !platform !builder !cPath !oPath !mExePath@@ -124,7 +126,7 @@                     (case mExePath of                       Nothing -> return ()                       Just exePath-                       -> do buildLdExe builder oPath exePath+                       -> do buildLdExe builder [oPath] exePath                              return ())                      -- Remove intermediate .c files if we weren't asked for them.

@@ -1,17 +1,22 @@ {-# LANGUAGE GADTs #-} module DDC.Build.Pipeline.Text-        ( PipeText (..)+        ( -- InterfaceAA+          PipeText (..)         , pipeText) where import DDC.Build.Pipeline.Error import DDC.Build.Pipeline.Sink import DDC.Build.Pipeline.Core import DDC.Build.Language+import DDC.Build.Interface.Store                (Store) import DDC.Base.Pretty -import qualified DDC.Source.Tetra.ToCore           as SE+import qualified DDC.Build.Transform.Resolve       as B++import qualified DDC.Source.Tetra.Convert          as SE import qualified DDC.Source.Tetra.Transform.Defix  as SE import qualified DDC.Source.Tetra.Transform.Expand as SE+import qualified DDC.Source.Tetra.Pretty           () import qualified DDC.Source.Tetra.Parser           as SE import qualified DDC.Source.Tetra.Lexer            as SE import qualified DDC.Source.Tetra.Env              as SE@@ -20,13 +25,14 @@ import qualified DDC.Core.Tetra                    as CE import qualified DDC.Core.Tetra.Env                as CE -import qualified DDC.Core.Parser                   as C+import qualified DDC.Core.Fragment                 as C import qualified DDC.Core.Transform.SpreadX        as C import qualified DDC.Core.Check                    as C import qualified DDC.Core.Load                     as C import qualified DDC.Core.Lexer                    as C import qualified DDC.Base.Parser                   as BP import qualified DDC.Data.SourcePos                as SP+import qualified DDC.Data.Token                    as Token import Control.DeepSeq  @@ -45,9 +51,12 @@         -> PipeText n err    PipeTextLoadSourceTetra-        :: !Sink                -- Sink for source tokens.-        -> !Sink                -- Sink for core code before final type checking.-        -> !Sink                -- Sink for type checker trace.+        :: !Sink        -- Sink for source tokens.+        -> !Sink        -- Sink for desugared source code.+        -> !Sink        -- Sink for core tetra code after conversoin.+        -> !Sink        -- Sink for core tetra code before type checking.+        -> !Sink        -- Sink for type checker trace.+        -> !Store       -- Interface store.         -> ![PipeCore (C.AnTEC BP.SourcePos CE.Name) CE.Name]         -> PipeText n err @@ -83,29 +92,27 @@          PipeTextLoadSourceTetra                  sinkTokens-                sinkPreCheck -                sinkCheckerTrace pipes+                sinkDesugared sinkCore sinkPreCheck sinkCheckerTrace +                store pipes          -> {-# SCC "PipeTextLoadSourceTetra" #-}-            let goParse+            let +                goParse                  = do   -- Lex the input text into source tokens.                         let tokens  = SE.lexModuleString srcName srcLine str -                        pipeSink (unlines $ map show $ tokens) sinkTokens--                        -- Parse the source tokens.-                        let context = C.Context-                                { C.contextTrackedEffects         = True-                                , C.contextTrackedClosures        = True-                                , C.contextFunctionalEffects      = False-                                , C.contextFunctionalClosures     = False }+                        -- Dump tokens to file.+                        pipeSink (unlines $ map (show . Token.tokenTok) $ tokens) +                                sinkTokens +                        -- Parse the tokens into a Source Tetra module.                         case BP.runTokenParser C.describeTok srcName-                                (SE.pModule context) tokens of+                                (SE.pModule SE.context) tokens of                          Left err -> return [ErrorLoad err]                          Right mm -> goDesugar mm                  goDesugar mm-                 = case SE.defix SE.defaultFixTable mm of+                 =      -- Resolve fixity of infix operators.+                   case SE.defix SE.defaultFixTable mm of                         Left err  -> return [ErrorLoad err]                         Right mm' -> goToCore mm' @@ -114,23 +121,50 @@                         let mm_expand = SE.expand SE.configDefault                                              SE.primKindEnv SE.primTypeEnv mm +                        -- Dump desguared source code.+                        pipeSink (renderIndent $ ppr mm_expand) sinkDesugared+                         -- Convert Source Tetra to Core Tetra.-                        -- This source position is used to annotate the let expression-                        -- that holds all the top-level bindings.-                        let sp        = SP.SourcePos "<top level>" 1 1-                        let mm_core   = SE.toCoreModule sp mm_expand+                        -- This source position is used to annotate the +                        -- let-expression that holds all the top-level bindings.+                        let sp            = SP.SourcePos "<top level>" 1 1+                        case SE.coreOfSourceModule sp mm_expand of+                         Left err+                          -> return [ErrorLoad err] +                         Right mm_core+                          -> do -- Dump Core Tetra.+                                pipeSink (renderIndent $ ppr mm_core) sinkCore++                                -- Discover which module imported names are from, and+                                -- attach the meta-data which will be needed by follow-on+                                -- compilation, such as the arity of each super.+                                result <- B.resolveNamesInModule +                                                CE.primKindEnv CE.primTypeEnv+                                                store mm_core++                                case result of +                                 Left err          -> return [ErrorLoad err]+                                 Right mm_resolved -> goSpread mm_resolved++                goSpread mm+                 = do                         -- Spread types of data constructors into uses.-                        let mm_spread = C.spreadX -                                          CE.primKindEnv CE.primTypeEnv mm_core+                        let mm_spread   = C.spreadX CE.primKindEnv CE.primTypeEnv mm -                        -- Dump code before checking for debugging purposes.+                        -- Dump loaded code before type checking.                         pipeSink (renderIndent $ ppr mm_spread) sinkPreCheck -                        -- Use the existing checker pipeline to Synthesise-                        -- missing type annotations.+                        -- Type check the code, synthesising missing type annotations.+                        --  Insert casts to implicitly run suspended bindings along the way.+                        let fragment_implicit+                                = flip C.mapProfileOfFragment CE.fragment+                                $ C.mapFeaturesOfProfile +                                $ ( C.setFeature C.ImplicitRun True+                                  . C.setFeature C.ImplicitBox True)+                         pipeCore mm_spread-                           $ PipeCoreCheck CE.fragment C.Synth sinkCheckerTrace pipes+                          $ PipeCoreCheck fragment_implicit C.Synth sinkCheckerTrace pipes              in goParse @@ -138,8 +172,5 @@          = case mct of                 Nothing                 -> return []                 Just (C.CheckTrace doc) -> pipeSink (renderIndent doc) sink---  

@@ -0,0 +1,9 @@++module DDC.Build.Spec +        ( Spec          (..)+        , Component     (..)+        , specFieldsLibrary)+where+import DDC.Build.Spec.Base++

@@ -0,0 +1,73 @@++module DDC.Build.Spec.Base+        ( Spec          (..)+        , Component     (..)+        , specFieldsLibrary)+where+import DDC.Core.Module  (ModuleName)++-- | A build specification.+--   This specifies how to build a particular library or exectutable,+--   and is equivalent to a Haskell Cabal file.+data Spec+        = Spec+        { -- | Version number set by the first line of the file.+          specVersion                   :: String++          -- | Components in this build specification.+        , specComponents                :: [Component] }+        deriving Show+++-- | A build component.+data Component+        = SpecLibrary+        { -- | Name of the library.+          specLibraryName               :: String++          -- | Library version.+        , specLibraryVersion            :: String++          -- | Tetra modules to build, in dependency order.+        , specLibraryTetraModules       :: [ModuleName] ++          -- | Optional library meta-data.+          --   These fields are for informational purposes and are not +          --   nessesary to build the library itself.+        , specLibraryMeta               :: [(String, String)] }+++        | SpecExecutable+        { -- | Name of executable+          specExecutableName            :: String++          -- | Name of main module.+        , specExecutableTetraMain       :: ModuleName++          -- | Tetra modules to build, in dependency order.+        , specExecutableTetraOther      :: [ModuleName] ++          -- | Optional library meta-data.+          --   These fields are for informational purposes and are not +          --   nessesary to build the executable itself.+        , specExecutableMeta            :: [(String, String)] }+        deriving Show+++-------------------------------------------------------------------------------++-- | Names of all allowable fields in library metadata, and whether each+--   field is nessesary or optional.+specFieldsLibrary :: [(String, Bool)]+specFieldsLibrary+ =  [ (str, True)  | str <- +        [ "name"+        , "version"+        , "tetra-modules" ]]++ ++ [ (str, False) | str <-+        [ "author"+        , "maintainer"+        , "homepage"+        , "license"+        , "synopsis" ]]

@@ -0,0 +1,11 @@++module DDC.Build.Spec.Check+        (Error(..))+where++-- | Errors that can appear in a Build Spec file.+data Error+        = ErrorUnrecognisedField+        { errorField    :: String+        , errorValue    :: String }+        deriving Show

@@ -0,0 +1,234 @@++-- | Parser for DDC build spec files.+module DDC.Build.Spec.Parser+        ( parseBuildSpec+        , Error(..) )+where+import DDC.Build.Spec.Base+import DDC.Base.Pretty+import Control.Monad+import Data.List+import Data.Char+import Data.Maybe+import qualified DDC.Core.Module        as C+++---------------------------------------------------------------------------------------------------+-- | Problems that can arise when parsing a build spec file.+data Error +        -- | Empty Spec file.+        = ErrorEmpty+        { errorFilePath :: FilePath }++        -- | Parse error in Spec file.+        | ErrorParse+        { errorFilePath :: FilePath +        , errorLine     :: Int }++        -- | Required field is missing.+        | ErrorMissingField+        { errorFilePath :: FilePath+        , errorMissing  :: String }+        deriving Show+++instance Pretty Error where+ ppr err+  = case err of+        ErrorEmpty filePath+         -> vcat [ text filePath+                 , text "Empty file" ]++        ErrorParse filePath n+         -> vcat [ text filePath <> text ":" <> int n+                 , text "Parse error" ]++        ErrorMissingField filePath field+         -> vcat [ text filePath+                 , text "Missing field '" <> text field <> text "'" ]+++---------------------------------------------------------------------------------------------------+type LineNumber = Int+type StartCol   = Int++type Parser a   = [(LineNumber, StartCol, String)]  +                -> Either Error a+++-- | Parse a build specification.+parseBuildSpec :: FilePath -> String -> Either Error Spec+parseBuildSpec path str+ = let  -- Attach line numbers and starting column to each line.+        ls              = lines str+        lsNum           = zip [1..]  ls+        lsNumCols       = attachCols lsNum+   in   pBuildSpec path lsNumCols+++-- | Parse a build specification.+pBuildSpec :: FilePath -> Parser Spec+pBuildSpec path []+        = Left $ ErrorEmpty path++pBuildSpec path ((n, _s, str) : rest)+        -- Skip over blank lines+        | all (\c -> isSpace c || c == '\n') str+        = pBuildSpec path rest++        -- The build spec needs to start with the magic words and version number.+        | ["ddc", "build", version] <- words str+        = do    cs    <- pComponents path rest+                return  $ Spec+                        { specVersion           = version+                        , specComponents        = cs }++        | otherwise+        = Left $ ErrorParse path n+++-- | Parse a build component specification.+pComponents :: FilePath -> Parser [Component]+pComponents _path []+        = return []++pComponents path ((n, start, str) : rest)+        -- skip over blank lines+        | all (\c -> isSpace c || c == '\n') str+        = pComponents path rest++        -- parse a library specification+        | str == "library"+        , (lsLibrary, lsMore) +                <- span (\(_, start', _) -> start' == 0 || start' > start) rest+        = do    fs      <- pLibraryFields path lsLibrary+                more    <- pComponents    path lsMore+                return  $ fs : more++        -- parse an executable specification+        | str == "executable"+        , (lsExecutable, lsMore)+                <- span (\(_, start', _) -> start' == 0 || start' > start) rest+        = do    fs      <- pExecutableFields path lsExecutable+                more    <- pComponents       path lsMore+                return  $ fs : more++        | otherwise+        = Left $ ErrorParse path n+++---------------------------------------------------------------------------------------------------+-- | Parse the fields of a library specification.+pLibraryFields :: FilePath -> Parser Component+pLibraryFields path str+ = do   fs                          <- pFields path str+        (sName,         fs_name)    <- takeField path "name"             fs+        (sVersion,      fs_version) <- takeField path "version"          fs_name+        (sTetraModules, fs_modules) <- takeField path "tetra-modules"    fs_version++        let Just msTetra+                = sequence+                $ map C.readModuleName+                $ words $ sTetraModules++        return  $ SpecLibrary +                { specLibraryName          = sName+                , specLibraryVersion       = sVersion+                , specLibraryTetraModules  = msTetra+                , specLibraryMeta          = fs_modules }+++---------------------------------------------------------------------------------------------------+-- | Parse the fields of an executable specification.+pExecutableFields :: FilePath -> Parser Component+pExecutableFields path str+ = do   fs                          <- pFields path str+        (sName,           fs_name)  <- takeField      path "name"        fs+        (sTetraMain,      fs_main)  <- takeField      path "tetra-main"  fs_name+        let (sTetraOther, fs_other) =  takeFieldMaybe path "tetra-other" fs_main++        let Just mTetraMain+                = C.readModuleName sTetraMain++        let Just msTetra+                = sequence $ map C.readModuleName+                $ concat   $ maybeToList $ liftM words sTetraOther ++        return  $ SpecExecutable+                { specExecutableName       = sName+                , specExecutableTetraMain  = mTetraMain+                , specExecutableTetraOther = msTetra+                , specExecutableMeta       = fs_other }+++---------------------------------------------------------------------------------------------------+-- | Parse fields of a build specification.+pFields  :: FilePath -> Parser [(String, String)]+pFields _path []+        = return []++pFields path ((n, start, str) : rest)+        -- skip over blank lines+        | all (\c -> isSpace c || c == '\n') str+        = pFields path rest+        +        -- parse a single field.+        | (lsField, lsMore)      +                <- span (\(_, start', _) -> start' == 0 || start' > start) rest++        , (fieldName, ':' : fieldValue) +                <- span (\c -> c /= ':') +                $  str ++ concat [ s | (_, _, s) <- lsField]++        = do    let f   =  (chomp fieldName, chomp fieldValue)+                more    <- pFields path lsMore+                return  $ f : more++        | otherwise+        = Left $ ErrorParse path n+++-- | Take a named field from this list of fields.+takeField :: FilePath+          -> String -> [(String, String)] +          -> Either Error (String, [(String, String)])++takeField path name fs+ = case lookup name fs of+        Nothing -> Left $ ErrorMissingField path name+        Just s  -> return (s, delete (name, s) fs)+++-- | Take a named field from this list of fields.+takeFieldMaybe +        :: FilePath+        -> String -> [(String, String)] +        -> (Maybe String, [(String, String)])++takeFieldMaybe _path name fs+ = case lookup name fs of+        Nothing -> (Nothing, fs)+        Just s  -> (Just s,  delete (name, s) fs)+++---------------------------------------------------------------------------------------------------+-- | Attach starting column number to these lines.+attachCols +        :: [(LineNumber, String)] +        -> [(LineNumber, StartCol, String)]++attachCols lstrs+ = [ (ln, startCol 1 str, str) | (ln, str) <- lstrs ]+ where  startCol n ss  +         = case ss of+                []              -> 0+                ' '  : ss'      -> startCol (n + 1) ss'+                '\t' : ss'      -> startCol (n + 8) ss'+                _    : _        -> n+++-- | Remove whitespace from the beginning and end of a string.+chomp :: String -> String+chomp str+        = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace str+

@@ -0,0 +1,186 @@++-- | Gather up the set of free names and try to find matching export statements+--   in the imported modules. Add explicit imports that refer to the module where+--   each name is bound.+module DDC.Build.Transform.Resolve+        ( resolveNamesInModule )+where+import DDC.Core.Module+import DDC.Core.Exp+import DDC.Core.Collect.Support+import DDC.Type.DataDef+import DDC.Type.Env                             (KindEnv, TypeEnv)+import DDC.Base.Pretty+import DDC.Base.Panic+import Data.Map                                 (Map)+import DDC.Build.Interface.Store                (Store)+import DDC.Build.Interface.Base                 (Interface (..))+import qualified Data.Map                       as Map+import qualified Data.Set                       as Set+import qualified DDC.Build.Interface.Store      as Store+import qualified DDC.Core.Tetra                 as E+import Data.List+import Data.Function+++-- | For all the names that are free in this module, if there is a+--   corresponding export in one of the modules in the given map,+--   then add the appropriate import definition.+resolveNamesInModule +        :: KindEnv E.Name       -- ^ Kinds of primitive types.+        -> TypeEnv E.Name       -- ^ Types of primitive values.+        -> Store                -- ^ Interface store.+        -> Module a E.Name      -- ^ Module to resolve names in.+        -> IO (Either [Error] (Module a E.Name))++resolveNamesInModule kenv tenv store mm+ = do+        let sp      = support kenv tenv mm+        ints    <- Store.getInterfaces store+        let deps    = Map.fromList +                        [ ( interfaceModuleName i+                          , let Just m = interfaceTetraModule i in m)+                          | i <- ints ]+        modNames       <- Store.getModuleNames store++        let getDaVarImport (UName n) = do+                eImport <- findImportSourceForDaVar store modNames n+                case eImport of+                 Left err       -> return $ Left err+                 Right isrc     -> return $ Right (n, isrc)++            getDaVarImport u    =   panic "ddc-build" "resolveNamesInModule"+                                $   text  "Cannot resolve anonymous binder:"+                                <+> ppr u++        eimportsDaVar   <- mapM getDaVarImport $ Set.toList $ supportDaVar sp++        case sequence eimportsDaVar of+         Left err       -> return $ Left [err]++         Right importsDaVar+          -> return $ Right $ mm +           { moduleImportTypes   +                =  moduleImportTypes  mm +                ++ importsForTyCons   deps (Set.toList $ supportTyCon sp)++           , moduleImportDataDefs+                =  nubBy ((==) `on` dataDefTypeName)          +                $  moduleImportDataDefs mm +                ++ importsForDaTyCons deps (Set.toList $ supportTyCon sp)++           , moduleImportCaps+                = moduleImportCaps mm+                ++ importsCap deps++           , moduleImportValues  +                =  moduleImportValues mm +                ++ importsDaVar }+++---------------------------------------------------------------------------------------------------+-- | Import tycons defined in other modules.+importsForTyCons+        :: Ord n+        => Map ModuleName (Module b n)  -- ^ Modules which this one depends on.+        -> [Bound n]                    -- ^ Unbound type constructors to find imports for.+        -> [(n, ImportType n)]++importsForTyCons deps _tyCons+ = concat+        [ [(n, ImportTypeAbstract k)+                | (n, k)        <- Map.toList $ Map.unions +                                $  map importedTyConsAbs   $ Map.elems deps]++        , [(n, ImportTypeAbstract k)+                | (n, (_, k))   <- Map.toList $ Map.unions +                                $  map exportedTyConsLocal $ Map.elems deps]++        , [(n, ImportTypeBoxed k) +                | (n, k)        <- Map.toList $ Map.unions +                                $  map importedTyConsBoxed $ Map.elems deps] ]+++---------------------------------------------------------------------------------------------------+-- | Import caps defined in other modules.+importsCap+        :: Ord n+        => Map ModuleName (Module b n)+        -> [(n, ImportCap n)]++importsCap deps+ = concatMap moduleImportCaps $ Map.elems deps+++---------------------------------------------------------------------------------------------------+-- | Import data defs defined in other modules.+importsForDaTyCons+        :: Ord n+        => Map ModuleName (Module b n)+        -> [Bound n]+        -> [DataDef n]++importsForDaTyCons deps _tycons+        = concat+        $ [ moduleImportDataDefs m ++ moduleDataDefsLocal m+                | m <- Map.elems deps ]+++---------------------------------------------------------------------------------------------------+-- | Build import statements for the given list of unbound value variables.+--+--   We look in dependency modules for a matching export, +--   and produce the corresponding import statement to use it.+--+findImportSourceForDaVar+        :: Store                -- ^ Interface store.+        -> [ModuleName]         -- ^ Modules to search for matching exports.+        -> E.Name               -- ^ Name of value.+        -> IO (Either Error (ImportValue E.Name))++findImportSourceForDaVar store modNames nSuper+ = do   result  <- Store.findSuper store nSuper modNames+        case result of+         []      -> return $ Left  $ ErrorNotFound nSuper+         [super] -> return $ Right $ Store.superImportValue super+         supers  -> return $ Left  $ ErrorMultiple nSuper (map Store.superModuleName supers)+++---------------------------------------------------------------------------------------------------+-- | Get the tycons that are locally defined, then exported by a module.+exportedTyConsLocal :: Ord n => Module b n -> Map n (ModuleName, Kind n)+exportedTyConsLocal mm+        = Map.fromList+        $ [ (n, (moduleName mm, t)) +                        | (n, ExportSourceLocal _ t) <- moduleExportTypes mm ]++-- | Get the type constructors that are imported abstractly by a module.+importedTyConsAbs  :: Ord n => Module b n -> Map n (Kind n)+importedTyConsAbs mm+        = Map.fromList+        $ [ (n, k)      | (n, ImportTypeAbstract k)  <- moduleImportTypes mm ]+++-- | Get the type constructors that are imported as boxed foreign types.+importedTyConsBoxed :: Ord n => Module b n -> Map n (Kind n)+importedTyConsBoxed mm+        = Map.fromList+        $ [ (n, k)      | (n, ImportTypeBoxed k)      <- moduleImportTypes mm ]+++---------------------------------------------------------------------------------------------------+-- | Problems that can be uncovered when resolving names.+data Error+        = ErrorNotFound E.Name+        | ErrorMultiple E.Name [ModuleName]++instance Pretty Error where+ ppr err+  = case err of+        ErrorNotFound n+         -> vcat [ text "Not in scope: " <> squotes (ppr n) ]++        ErrorMultiple n ms+         -> vcat $  [ text "Variable" <+> squotes (ppr n) <+> text "defined in multiple modules:" ]+                 ++ (map ppr ms)+         

@@ -1,5 +1,5 @@ Name:           ddc-build-Version:        0.4.1.3+Version:        0.4.2.1 License:        MIT License-file:   LICENSE Author:         The Disciplined Disciple Compiler Strike Force@@ -14,27 +14,30 @@  Library   Build-depends:-        base             >= 4.6 && < 4.8,+        base             >= 4.6 && < 4.9,         process          >= 1.1 && < 1.3,-        deepseq          == 1.3.*,+        deepseq          >= 1.3 && < 1.5,         containers       == 0.5.*,-        filepath         == 1.3.*,+        filepath         >= 1.3 && < 1.5,         directory        == 1.2.*,-        mtl              == 2.2.*,-        ddc-base         == 0.4.1.*,-        ddc-core         == 0.4.1.*,-        ddc-core-eval    == 0.4.1.*,-        ddc-core-simpl   == 0.4.1.*,-        ddc-core-salt    == 0.4.1.*,-        ddc-core-llvm    == 0.4.1.*,-        ddc-core-flow    == 0.4.1.*,-        ddc-core-tetra   == 0.4.1.*,-        ddc-source-tetra == 0.4.1.*+        mtl              == 2.2.1.*,+        time             >= 1.4 && < 1.6,+        ddc-base         == 0.4.2.*,+        ddc-core         == 0.4.2.*,+        ddc-core-simpl   == 0.4.2.*,+        ddc-core-salt    == 0.4.2.*,+        ddc-core-llvm    == 0.4.2.*,+        ddc-core-flow    == 0.4.2.*,+        ddc-core-tetra   == 0.4.2.*,+        ddc-core-babel   == 0.4.2.*,+        ddc-source-tetra == 0.4.2.*      Exposed-modules:-        DDC.Build.Language.Eval+        DDC.Build.Interface.Base+        DDC.Build.Interface.Load+        DDC.Build.Interface.Store+         DDC.Build.Language.Flow-        DDC.Build.Language.Lite         DDC.Build.Language.Salt         DDC.Build.Language.Tetra         DDC.Build.Language.Zero@@ -46,13 +49,19 @@         DDC.Build.Pipeline.Sink         DDC.Build.Pipeline.Text         +        DDC.Build.Spec.Check+        DDC.Build.Spec.Parser+         DDC.Build.Builder         DDC.Build.Language         DDC.Build.Pipeline         DDC.Build.Platform+        DDC.Build.Spec            Other-modules:         DDC.Build.Language.Base+        DDC.Build.Spec.Base+        DDC.Build.Transform.Resolve    Extensions:         BangPatterns@@ -65,6 +74,7 @@         KindSignatures         RankNTypes         DeriveDataTypeable+        ScopedTypeVariables    ghc-options:         -Wall