Source maps

builder/src/Generate.hs

@@ -37,7 +37,7 @@ import Prelude hiding (cycle, print)
 type Task a =
   Task.Task Exit.Generate a
 
-debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
+debug :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult
 debug root details (Build.Artifacts pkg ifaces roots modules) =
   do
     loading <- loadObjects root details modules
@@ -48,7 +48,7 @@ debug root details (Build.Artifacts pkg ifaces roots modules) =
     let mains = gatherMains pkg objects roots
     return $ JS.generate mode graph mains
 
-dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
+dev :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult
 dev root details (Build.Artifacts pkg _ roots modules) =
   do
     objects <- finalizeObjects =<< loadObjects root details modules
@@ -57,7 +57,7 @@ dev root details (Build.Artifacts pkg _ roots modules) =
     let mains = gatherMains pkg objects roots
     return $ JS.generate mode graph mains
 
-prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder
+prod :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult
 prod root details (Build.Artifacts pkg _ roots modules) =
   do
     objects <- finalizeObjects =<< loadObjects root details modules

builder/src/Gren/Outline.hs

@@ -20,17 +20,21 @@ module Gren.Outline
     sourceDirs,
     platform,
     dependencyConstraints,
+    getAllModulePaths,
   )
 where
 
 import AbsoluteSrcDir (AbsoluteSrcDir)
 import AbsoluteSrcDir qualified
 import Control.Monad (filterM, liftM)
 import Data.Binary (Binary, get, getWord8, put, putWord8)
+import Data.Function ((&))
 import Data.List qualified as List
 import Data.Map qualified as Map
+import Data.Name qualified as Name
 import Data.NonEmptyList qualified as NE
 import Data.OneOrMore qualified as OneOrMore
+import Directories qualified
 import File qualified
 import Foreign.Ptr (minusPtr)
 import Gren.Constraint qualified as Con
@@ -262,6 +266,68 @@ sourceDirs outline =
     Pkg _ ->
       NE.singleton (RelativeSrcDir "src")
 
+-- getAllModulePaths
+
+getAllModulePaths :: FilePath -> IO (Map.Map ModuleName.Canonical FilePath)
+getAllModulePaths root =
+  do
+    outlineResult <- read root
+    case outlineResult of
+      Left _ ->
+        return Map.empty
+      Right outline ->
+        case outline of
+          App appOutline ->
+            let deps = Map.union (_app_deps_direct appOutline) (_app_deps_indirect appOutline)
+                srcDirs = map (toAbsolute root) (NE.toList (_app_source_dirs appOutline))
+             in getAllModulePathsHelper Pkg.dummyName srcDirs deps
+          Pkg pkgOutline ->
+            let deps = Map.map (PossibleFilePath.mapWith Con.lowerBound) (_pkg_deps pkgOutline)
+             in getAllModulePathsHelper (_pkg_name pkgOutline) [root </> "src"] deps
+
+getAllModulePathsHelper :: Pkg.Name -> [FilePath] -> Map.Map Pkg.Name (PossibleFilePath V.Version) -> IO (Map.Map ModuleName.Canonical FilePath)
+getAllModulePathsHelper packageName packageSrcDirs deps =
+  do
+    grenFiles <- traverse recursiveFindGrenFiles packageSrcDirs
+    let asMap = Map.fromList $ map (\(root, fp) -> (ModuleName.Canonical packageName (moduleNameFromFilePath root fp), fp)) (concat grenFiles)
+    dependencyRoots <- Map.traverseWithKey resolvePackagePaths deps
+    dependencyMaps <- traverse (\(pkgName, pkgRoot) -> getAllModulePathsHelper pkgName [pkgRoot </> "src"] Map.empty) dependencyRoots
+    return $ foldr Map.union asMap dependencyMaps
+
+recursiveFindGrenFiles :: FilePath -> IO [(FilePath, FilePath)]
+recursiveFindGrenFiles root = do
+  files <- recursiveFindGrenFilesHelp root
+  return $ map (\f -> (root, f)) files
+
+recursiveFindGrenFilesHelp :: FilePath -> IO [FilePath]
+recursiveFindGrenFilesHelp root =
+  do
+    dirContents <- Dir.getDirectoryContents root
+    let (grenFiles, others) = List.partition (List.isSuffixOf ".gren") dirContents
+    subDirectories <- filterM (\fp -> Dir.doesDirectoryExist (root </> fp)) (filter (\fp -> fp /= "." && fp /= "..") others)
+    filesFromSubDirs <- traverse (recursiveFindGrenFilesHelp . (root </>)) subDirectories
+    return $ concat filesFromSubDirs ++ map (\fp -> root </> fp) grenFiles
+
+moduleNameFromFilePath :: FilePath -> FilePath -> Name.Name
+moduleNameFromFilePath root filePath =
+  filePath
+    & drop (List.length root + 1)
+    & reverse
+    & drop 5 -- .gren
+    & reverse
+    & map (\c -> if c == '/' then '.' else c)
+    & Name.fromChars
+
+resolvePackagePaths :: Pkg.Name -> PossibleFilePath V.Version -> IO (Pkg.Name, FilePath)
+resolvePackagePaths pkgName versionOrFilePath =
+  case versionOrFilePath of
+    PossibleFilePath.Other vsn ->
+      do
+        packageCache <- Directories.getPackageCache
+        return (pkgName, Directories.package packageCache pkgName vsn)
+    PossibleFilePath.Is filePath ->
+      return (pkgName, filePath)
+
 -- JSON DECODE
 
 type Decoder a =

compiler/src/AST/Canonical.hs

@@ -98,8 +98,8 @@ data Expr_
   | Case Expr [CaseBranch]
   | Accessor Name
   | Access Expr (A.Located Name)
-  | Update Expr (Map.Map Name FieldUpdate)
-  | Record (Map.Map Name Expr)
+  | Update Expr (Map.Map (A.Located Name) FieldUpdate)
+  | Record (Map.Map (A.Located Name) Expr)
   deriving (Show)
 
 data CaseBranch

compiler/src/AST/Optimized.hs

@@ -40,38 +40,38 @@ import Reporting.Annotation qualified as A
 -- EXPRESSIONS
 
 data Expr
-  = Bool Bool
-  | Chr ES.String
-  | Str ES.String
-  | Int Int
-  | Float EF.Float
-  | VarLocal Name
-  | VarGlobal Global
-  | VarEnum Global Index.ZeroBased
-  | VarBox Global
-  | VarCycle ModuleName.Canonical Name
-  | VarDebug Name ModuleName.Canonical A.Region (Maybe Name)
-  | VarKernel Name Name
-  | Array [Expr]
-  | Function [Name] Expr
-  | Call Expr [Expr]
+  = Bool A.Region Bool
+  | Chr A.Region ES.String
+  | Str A.Region ES.String
+  | Int A.Region Int
+  | Float A.Region EF.Float
+  | VarLocal A.Region Name
+  | VarGlobal A.Region Global
+  | VarEnum A.Region Global Index.ZeroBased
+  | VarBox A.Region Global
+  | VarCycle A.Region ModuleName.Canonical Name
+  | VarDebug A.Region Name ModuleName.Canonical (Maybe Name)
+  | VarKernel A.Region Name Name
+  | Array A.Region [Expr]
+  | Function [A.Located Name] Expr
+  | Call A.Region Expr [Expr]
   | TailCall Name [(Name, Expr)]
   | If [(Expr, Expr)] Expr
   | Let Def Expr
   | Destruct Destructor Expr
   | Case Name Name (Decider Choice) [(Int, Expr)]
-  | Accessor Name
-  | Access Expr Name
-  | Update Expr (Map.Map Name Expr)
-  | Record (Map.Map Name Expr)
+  | Accessor A.Region Name
+  | Access Expr A.Region Name
+  | Update A.Region Expr (Map.Map (A.Located Name) Expr)
+  | Record A.Region (Map.Map (A.Located Name) Expr)
 
 data Global = Global ModuleName.Canonical Name
 
 -- DEFINITIONS
 
 data Def
-  = Def Name Expr
-  | TailDef Name [Name] Expr
+  = Def A.Region Name Expr
+  | TailDef A.Region Name [A.Located Name] Expr
 
 data Destructor
   = Destructor Name Path
@@ -125,8 +125,8 @@ data Main
       }
 
 data Node
-  = Define Expr (Set.Set Global)
-  | DefineTailFunc [Name] Expr (Set.Set Global)
+  = Define A.Region Expr (Set.Set Global)
+  | DefineTailFunc A.Region [A.Located Name] Expr (Set.Set Global)
   | Ctor Index.ZeroBased Int
   | Enum Index.ZeroBased
   | Box
@@ -206,73 +206,73 @@ instance Binary Global where
 instance Binary Expr where
   put expr =
     case expr of
-      Bool a -> putWord8 0 >> put a
-      Chr a -> putWord8 1 >> put a
-      Str a -> putWord8 2 >> put a
-      Int a -> putWord8 3 >> put a
-      Float a -> putWord8 4 >> put a
-      VarLocal a -> putWord8 5 >> put a
-      VarGlobal a -> putWord8 6 >> put a
-      VarEnum a b -> putWord8 7 >> put a >> put b
-      VarBox a -> putWord8 8 >> put a
-      VarCycle a b -> putWord8 9 >> put a >> put b
+      Bool a b -> putWord8 0 >> put a >> put b
+      Chr a b -> putWord8 1 >> put a >> put b
+      Str a b -> putWord8 2 >> put a >> put b
+      Int a b -> putWord8 3 >> put a >> put b
+      Float a b -> putWord8 4 >> put a >> put b
+      VarLocal a b -> putWord8 5 >> put a >> put b
+      VarGlobal a b -> putWord8 6 >> put a >> put b
+      VarEnum a b c -> putWord8 7 >> put a >> put b >> put c
+      VarBox a b -> putWord8 8 >> put a >> put b
+      VarCycle a b c -> putWord8 9 >> put a >> put b >> put c
       VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d
-      VarKernel a b -> putWord8 11 >> put a >> put b
-      Array a -> putWord8 12 >> put a
+      VarKernel a b c -> putWord8 11 >> put a >> put b >> put c
+      Array a b -> putWord8 12 >> put a >> put b
       Function a b -> putWord8 13 >> put a >> put b
-      Call a b -> putWord8 14 >> put a >> put b
+      Call a b c -> putWord8 14 >> put a >> put b >> put c
       TailCall a b -> putWord8 15 >> put a >> put b
       If a b -> putWord8 16 >> put a >> put b
       Let a b -> putWord8 17 >> put a >> put b
       Destruct a b -> putWord8 18 >> put a >> put b
       Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d
-      Accessor a -> putWord8 20 >> put a
-      Access a b -> putWord8 21 >> put a >> put b
-      Update a b -> putWord8 22 >> put a >> put b
-      Record a -> putWord8 23 >> put a
+      Accessor a b -> putWord8 20 >> put a >> put b
+      Access a b c -> putWord8 21 >> put a >> put b >> put c
+      Update a b c -> putWord8 22 >> put a >> put b >> put c
+      Record a b -> putWord8 23 >> put a >> put b
 
   get =
     do
       word <- getWord8
       case word of
-        0 -> liftM Bool get
-        1 -> liftM Chr get
-        2 -> liftM Str get
-        3 -> liftM Int get
-        4 -> liftM Float get
-        5 -> liftM VarLocal get
-        6 -> liftM VarGlobal get
-        7 -> liftM2 VarEnum get get
-        8 -> liftM VarBox get
-        9 -> liftM2 VarCycle get get
+        0 -> liftM2 Bool get get
+        1 -> liftM2 Chr get get
+        2 -> liftM2 Str get get
+        3 -> liftM2 Int get get
+        4 -> liftM2 Float get get
+        5 -> liftM2 VarLocal get get
+        6 -> liftM2 VarGlobal get get
+        7 -> liftM3 VarEnum get get get
+        8 -> liftM2 VarBox get get
+        9 -> liftM3 VarCycle get get get
         10 -> liftM4 VarDebug get get get get
-        11 -> liftM2 VarKernel get get
-        12 -> liftM Array get
+        11 -> liftM3 VarKernel get get get
+        12 -> liftM2 Array get get
         13 -> liftM2 Function get get
-        14 -> liftM2 Call get get
+        14 -> liftM3 Call get get get
         15 -> liftM2 TailCall get get
         16 -> liftM2 If get get
         17 -> liftM2 Let get get
         18 -> liftM2 Destruct get get
         19 -> liftM4 Case get get get get
-        20 -> liftM Accessor get
-        21 -> liftM2 Access get get
-        22 -> liftM2 Update get get
-        23 -> liftM Record get
+        20 -> liftM2 Accessor get get
+        21 -> liftM3 Access get get get
+        22 -> liftM3 Update get get get
+        23 -> liftM2 Record get get
         _ -> fail "problem getting Opt.Expr binary"
 
 instance Binary Def where
   put def =
     case def of
-      Def a b -> putWord8 0 >> put a >> put b
-      TailDef a b c -> putWord8 1 >> put a >> put b >> put c
+      Def a b c -> putWord8 0 >> put a >> put b >> put c
+      TailDef a b c d -> putWord8 1 >> put a >> put b >> put c >> put d
 
   get =
     do
       word <- getWord8
       case word of
-        0 -> liftM2 Def get get
-        1 -> liftM3 TailDef get get get
+        0 -> liftM3 Def get get get
+        1 -> liftM4 TailDef get get get get
         _ -> fail "problem getting Opt.Def binary"
 
 instance Binary Destructor where
@@ -356,8 +356,8 @@ instance Binary Main where
 instance Binary Node where
   put node =
     case node of
-      Define a b -> putWord8 0 >> put a >> put b
-      DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c
+      Define a b c -> putWord8 0 >> put a >> put b >> put c
+      DefineTailFunc a b c d -> putWord8 1 >> put a >> put b >> put c >> put d
       Ctor a b -> putWord8 2 >> put a >> put b
       Enum a -> putWord8 3 >> put a
       Box -> putWord8 4
@@ -372,8 +372,8 @@ instance Binary Node where
     do
       word <- getWord8
       case word of
-        0 -> liftM2 Define get get
-        1 -> liftM3 DefineTailFunc get get get
+        0 -> liftM3 Define get get get
+        1 -> liftM4 DefineTailFunc get get get get
         2 -> liftM2 Ctor get get
         3 -> liftM Enum get
         4 -> return Box

compiler/src/Canonicalize/Environment/Dups.hs

@@ -1,10 +1,10 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wall #-}
-
 module Canonicalize.Environment.Dups
   ( detect,
+    detectLocated,
     checkFields,
+    checkLocatedFields,
     checkFields',
+    checkLocatedFields',
     Dict,
     none,
     one,
@@ -14,7 +14,9 @@ module Canonicalize.Environment.Dups
   )
 where
 
+import Data.Function ((&))
 import Data.Map qualified as Map
+import Data.Maybe qualified as Maybe
 import Data.Name qualified as Name
 import Data.OneOrMore qualified as OneOrMore
 import Reporting.Annotation qualified as A
@@ -40,6 +42,19 @@ detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name
 detect toError dict =
   Map.traverseWithKey (detectHelp toError) dict
 
+detectLocated :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) a)
+detectLocated toError dict =
+  let nameLocations = Map.mapMaybe extractLocation dict
+   in dict
+        & Map.mapKeys (\k -> A.At (Maybe.fromMaybe A.zero $ Map.lookup k nameLocations) k)
+        & Map.traverseWithKey (\(A.At _ name) values -> detectHelp toError name values)
+
+extractLocation :: OneOrMore.OneOrMore (Info a) -> Maybe A.Region
+extractLocation oneOrMore =
+  case oneOrMore of
+    OneOrMore.One (Info region _) -> Just region
+    OneOrMore.More _ _ -> Nothing
+
 detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a
 detectHelp toError name values =
   case values of
@@ -52,6 +67,10 @@ detectHelp toError name values =
 
 -- CHECK FIELDS
 
+checkLocatedFields :: [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) a)
+checkLocatedFields fields =
+  detectLocated Error.DuplicateField (foldr addField none fields)
+
 checkFields :: [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map Name.Name a)
 checkFields fields =
   detect Error.DuplicateField (foldr addField none fields)
@@ -60,6 +79,10 @@ addField :: (A.Located Name.Name, a, comments) -> Dict a -> Dict a
 addField (A.At region name, value, _) dups =
   Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups
 
+checkLocatedFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) b)
+checkLocatedFields' toValue fields =
+  detectLocated Error.DuplicateField (foldr (addField' toValue) none fields)
+
 checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map Name.Name b)
 checkFields' toValue fields =
   detect Error.DuplicateField (foldr (addField' toValue) none fields)