mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-11 08:45:42 +03:00
Merge remote-tracking branch 'origin/main' into avh4/format
This commit is contained in:
commit
f91dd33c25
2
.github/workflows/releases.yml
vendored
2
.github/workflows/releases.yml
vendored
@ -31,7 +31,7 @@ jobs:
|
||||
- uses: haskell/actions/setup@v1
|
||||
id: setup-haskell
|
||||
with:
|
||||
ghc-version: '9.2.2'
|
||||
ghc-version: '9.2.4'
|
||||
cabal-version: '3.6'
|
||||
|
||||
- name: Cache
|
||||
|
4
.github/workflows/verify.yml
vendored
4
.github/workflows/verify.yml
vendored
@ -15,12 +15,12 @@ jobs:
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
|
||||
- uses: mrkkrp/ormolu-action@v5
|
||||
- uses: mrkkrp/ormolu-action@v6
|
||||
|
||||
- uses: haskell/actions/setup@v1
|
||||
id: setup-haskell
|
||||
with:
|
||||
ghc-version: '9.2.2'
|
||||
ghc-version: '9.2.4'
|
||||
cabal-version: '3.6'
|
||||
|
||||
- name: Cache
|
||||
|
@ -1,6 +1,5 @@
|
||||
|
||||
# Local development commands
|
||||
|
||||
- build: `cabal build -f dev`
|
||||
- run tests: `cabal test -f dev`
|
||||
- format files: `find -name '*.hs' | xargs -t ormolu -m inplace`
|
||||
- format files: `ormolu --mode inplace $(git ls-files '*.hs')`
|
||||
|
@ -1 +1,4 @@
|
||||
Robin Heggelund Hansen
|
||||
Robin Heggelund Hansen (robinheghan)
|
||||
Julian Antonielli (jjant)
|
||||
Aaron VonderHaar (avh4)
|
||||
lue (lue-bird)
|
||||
|
17
README.md
17
README.md
@ -2,19 +2,12 @@
|
||||
|
||||
Compiler for the Gren programming language.
|
||||
|
||||
## Installing
|
||||
If you wish to install the compiler, you might want to read the [setup instructions](https://gren-lang.org/install).
|
||||
|
||||
Binaries are available for every commit to master [here](https://github.com/gren-lang/compiler/actions/workflows/releases.yml).
|
||||
Once downloaded, you'll need to unzip the binary and place it somewhere in your `PATH`, and give it execute permissions.
|
||||
## Build from source
|
||||
|
||||
Example (OS X):
|
||||
Then Gren compiler is written in Haskell, so to build from source you need to have GHC 9.2.2 (haskell compiler) and cabal 3.6 (haskell build tool) installed on your system.
|
||||
|
||||
```bash
|
||||
# Download to ~/Downloads/gren-macOS.zip
|
||||
cd ~/Downloads
|
||||
unzip gren-macOS.zip
|
||||
chmod +x gren
|
||||
mv gren /usr/local/bin/
|
||||
Compiling the project should just be a matter of running `cabal build`, or `cabal install` if you wish to install the compiler on your machine.
|
||||
|
||||
gren # Success
|
||||
```
|
||||
Read the [CONTRIBUTING.md]() file for some helpful commands for working on the compiler itself.
|
||||
|
@ -6,7 +6,7 @@ module AbsoluteSrcDir
|
||||
)
|
||||
where
|
||||
|
||||
import qualified System.Directory as Dir
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ((</>))
|
||||
|
||||
newtype AbsoluteSrcDir
|
||||
|
@ -9,9 +9,9 @@ where
|
||||
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
|
||||
import qualified Data.Binary as Binary
|
||||
import Data.Binary qualified as Binary
|
||||
import Data.Foldable (traverse_)
|
||||
import qualified File
|
||||
import File qualified
|
||||
|
||||
-- BACKGROUND WRITER
|
||||
|
||||
|
@ -17,48 +17,48 @@ module Build
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Source as Src
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Source qualified as Src
|
||||
import AbsoluteSrcDir (AbsoluteSrcDir (..))
|
||||
import qualified AbsoluteSrcDir
|
||||
import qualified Compile
|
||||
import AbsoluteSrcDir qualified
|
||||
import Compile qualified
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad (filterM)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Graph as Graph
|
||||
import qualified Data.List as List
|
||||
import Data.ByteString qualified as B
|
||||
import Data.Char qualified as Char
|
||||
import Data.Graph qualified as Graph
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict ((!))
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Map.Utils as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified Data.Set as Set
|
||||
import qualified Directories as Dirs
|
||||
import qualified File
|
||||
import qualified Gren.Details as Details
|
||||
import qualified Gren.Docs as Docs
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Outline as Outline
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Json.Encode as E
|
||||
import qualified Parse.Module as Parse
|
||||
import qualified Reporting
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error as Error
|
||||
import qualified Reporting.Error.Docs as EDocs
|
||||
import qualified Reporting.Error.Import as Import
|
||||
import qualified Reporting.Error.Syntax as Syntax
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import qualified System.Directory as Dir
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Map.Utils qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Data.Set qualified as Set
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.Docs qualified as Docs
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Module qualified as Parse
|
||||
import Reporting qualified
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error qualified as Error
|
||||
import Reporting.Error.Docs qualified as EDocs
|
||||
import Reporting.Error.Import qualified as Import
|
||||
import Reporting.Error.Syntax qualified as Syntax
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import qualified System.FilePath as FP
|
||||
import System.FilePath qualified as FP
|
||||
|
||||
-- ENVIRONMENT
|
||||
|
||||
@ -79,7 +79,7 @@ makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
|
||||
do
|
||||
srcDirs <- traverse (Outline.toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
|
||||
return $ Env key root Parse.Application srcDirs buildID locals foreigns
|
||||
Details.ValidPkg pkg _ _ ->
|
||||
Details.ValidPkg pkg _ ->
|
||||
do
|
||||
srcDir <- Outline.toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
|
||||
return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
|
||||
@ -846,7 +846,8 @@ checkRoots infos =
|
||||
loc2 : _ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
|
||||
in fmap (\_ -> fmap _location infos) $
|
||||
traverse (OneOrMore.destruct fromOneOrMore) $
|
||||
Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
|
||||
Map.fromListWith OneOrMore.more $
|
||||
map toOneOrMore (NE.toList infos)
|
||||
|
||||
-- ROOT INFO
|
||||
|
||||
|
@ -12,30 +12,30 @@ module Deps.Diff
|
||||
)
|
||||
where
|
||||
|
||||
import qualified BackgroundWriter as BW
|
||||
import qualified Build
|
||||
import BackgroundWriter qualified as BW
|
||||
import Build qualified
|
||||
import Control.Monad (zipWithM)
|
||||
import Data.Function (on)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.Set as Set
|
||||
import qualified Deps.Package as Package
|
||||
import qualified Directories as Dirs
|
||||
import qualified File
|
||||
import qualified Gren.Compiler.Type as Type
|
||||
import qualified Gren.Details as Details
|
||||
import qualified Gren.Docs as Docs
|
||||
import qualified Gren.Magnitude as M
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Outline as Outline
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as D
|
||||
import qualified Reporting
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified Reporting.Task as Task
|
||||
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.Set qualified as Set
|
||||
import Deps.Package qualified as Package
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Gren.Compiler.Type qualified as Type
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.Docs qualified as Docs
|
||||
import Gren.Magnitude qualified as M
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Reporting qualified
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Task qualified as Task
|
||||
import System.FilePath ((</>))
|
||||
|
||||
-- CHANGES
|
||||
|
@ -1,33 +1,103 @@
|
||||
module Deps.Package
|
||||
( getVersions,
|
||||
--
|
||||
LatestCompatibleVersionError (..),
|
||||
latestCompatibleVersion,
|
||||
latestCompatibleVersionForPackages,
|
||||
--
|
||||
bumpPossibilities,
|
||||
installPackageVersion,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Directories as Dirs
|
||||
import qualified Git
|
||||
import qualified Gren.Magnitude as M
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified System.Directory as Dir
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Directories qualified as Dirs
|
||||
import Git qualified
|
||||
import Gren.Constraint qualified as C
|
||||
import Gren.Magnitude qualified as M
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import System.Directory qualified as Dir
|
||||
|
||||
-- GET VERSIONS
|
||||
|
||||
getVersions :: Dirs.PackageCache -> Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
|
||||
getVersions cache name = do
|
||||
let repoPath = Dirs.basePackage cache name
|
||||
repoExists <- Dir.doesDirectoryExist repoPath
|
||||
retVal <-
|
||||
if repoExists
|
||||
then Git.update name repoPath
|
||||
else Git.clone (Git.githubUrl name) repoPath
|
||||
case retVal of
|
||||
Left problem ->
|
||||
return $ Left problem
|
||||
Right () ->
|
||||
Git.tags repoPath
|
||||
getVersions :: Pkg.Name -> IO (Either Git.Error (V.Version, [V.Version]))
|
||||
getVersions name =
|
||||
Git.tags (Git.githubUrl name)
|
||||
|
||||
-- GET LATEST COMPATIBLE VERSION
|
||||
|
||||
data LatestCompatibleVersionError
|
||||
= NoCompatiblePackage
|
||||
| GitError Git.Error
|
||||
|
||||
latestCompatibleVersion ::
|
||||
Dirs.PackageCache ->
|
||||
Pkg.Name ->
|
||||
IO (Either LatestCompatibleVersionError V.Version)
|
||||
latestCompatibleVersion cache name = do
|
||||
versionsResult <- getVersions name
|
||||
case versionsResult of
|
||||
Right (first, rest) ->
|
||||
let versionsHighToLow = List.reverse $ List.sort (first : rest)
|
||||
in do
|
||||
potentiallyCompatibleVersion <- getCompatibleVersion cache name versionsHighToLow
|
||||
case potentiallyCompatibleVersion of
|
||||
Nothing ->
|
||||
return $ Left NoCompatiblePackage
|
||||
Just v ->
|
||||
return $ Right v
|
||||
Left gitError ->
|
||||
return $ Left $ GitError gitError
|
||||
|
||||
getCompatibleVersion :: Dirs.PackageCache -> Pkg.Name -> [V.Version] -> IO (Maybe V.Version)
|
||||
getCompatibleVersion cache name versions =
|
||||
case versions of
|
||||
[] ->
|
||||
return Nothing
|
||||
vsn : rest -> do
|
||||
potentialInstallationError <- installPackageVersion cache name vsn
|
||||
case potentialInstallationError of
|
||||
Left _ ->
|
||||
getCompatibleVersion cache name rest
|
||||
Right () -> do
|
||||
let pkgPath = Dirs.package cache name vsn
|
||||
potentialOutline <- Outline.read pkgPath
|
||||
case potentialOutline of
|
||||
Right (Outline.Pkg outline) ->
|
||||
if C.goodGren (Outline._pkg_gren_version outline)
|
||||
then return $ Just vsn
|
||||
else getCompatibleVersion cache name rest
|
||||
_ ->
|
||||
getCompatibleVersion cache name rest
|
||||
|
||||
-- LATEST COMPATIBLE VERSION FOR PACKAGES
|
||||
|
||||
latestCompatibleVersionForPackages ::
|
||||
Dirs.PackageCache ->
|
||||
[Pkg.Name] ->
|
||||
IO (Either LatestCompatibleVersionError (Map.Map Pkg.Name C.Constraint))
|
||||
latestCompatibleVersionForPackages cache pkgs =
|
||||
latestCompatibleVersionForPackagesHelp cache pkgs Map.empty
|
||||
|
||||
latestCompatibleVersionForPackagesHelp ::
|
||||
Dirs.PackageCache ->
|
||||
[Pkg.Name] ->
|
||||
Map.Map Pkg.Name C.Constraint ->
|
||||
IO (Either LatestCompatibleVersionError (Map.Map Pkg.Name C.Constraint))
|
||||
latestCompatibleVersionForPackagesHelp cache pkgs result =
|
||||
case pkgs of
|
||||
[] -> return $ Right result
|
||||
pkg : rest -> do
|
||||
possibleVersion <- latestCompatibleVersion cache pkg
|
||||
case possibleVersion of
|
||||
Left err ->
|
||||
return $ Left err
|
||||
Right vsn ->
|
||||
let newResult = Map.insert pkg (C.untilNextMajor vsn) result
|
||||
in latestCompatibleVersionForPackagesHelp cache rest newResult
|
||||
|
||||
-- GET POSSIBILITIES
|
||||
|
||||
@ -36,8 +106,8 @@ bumpPossibilities (latest, previous) =
|
||||
let allVersions = reverse (latest : previous)
|
||||
minorPoints = map last (List.groupBy sameMajor allVersions)
|
||||
patchPoints = map last (List.groupBy sameMinor allVersions)
|
||||
in (latest, V.bumpMajor latest, M.MAJOR) :
|
||||
map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
|
||||
in (latest, V.bumpMajor latest, M.MAJOR)
|
||||
: map (\v -> (v, V.bumpMinor v, M.MINOR)) minorPoints
|
||||
++ map (\v -> (v, V.bumpPatch v, M.PATCH)) patchPoints
|
||||
|
||||
sameMajor :: V.Version -> V.Version -> Bool
|
||||
@ -57,21 +127,4 @@ installPackageVersion cache pkg vsn = do
|
||||
if versionedPkgExists
|
||||
then return $ Right ()
|
||||
else do
|
||||
let basePkgPath = Dirs.basePackage cache pkg
|
||||
basePkgExists <- Dir.doesDirectoryExist basePkgPath
|
||||
if basePkgExists
|
||||
then do
|
||||
updateResult <- Git.update pkg basePkgPath
|
||||
case updateResult of
|
||||
Left updateErr ->
|
||||
return $ Left updateErr
|
||||
Right () ->
|
||||
Git.localClone basePkgPath vsn versionedPkgPath
|
||||
else do
|
||||
let gitUrl = Git.githubUrl pkg
|
||||
baseCloneResult <- Git.clone gitUrl basePkgPath
|
||||
case baseCloneResult of
|
||||
Left cloneErr ->
|
||||
return $ Left cloneErr
|
||||
Right () ->
|
||||
Git.localClone basePkgPath vsn versionedPkgPath
|
||||
Git.clone (Git.githubUrl pkg) vsn versionedPkgPath
|
||||
|
@ -18,16 +18,17 @@ where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Deps.Package as Package
|
||||
import qualified Directories as Dirs
|
||||
import qualified File
|
||||
import qualified Gren.Constraint as C
|
||||
import qualified Gren.Outline as Outline
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as D
|
||||
import qualified Reporting.Exit as Exit
|
||||
import Data.Map qualified as Map
|
||||
import Deps.Package qualified as Package
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Gren.Constraint qualified as C
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Reporting.Exit qualified as Exit
|
||||
import System.FilePath ((</>))
|
||||
|
||||
-- SOLVER
|
||||
@ -49,6 +50,7 @@ data State = State
|
||||
|
||||
data Constraints = Constraints
|
||||
{ _gren :: C.Constraint,
|
||||
_platform :: Platform.Platform,
|
||||
_deps :: Map.Map Pkg.Name C.Constraint
|
||||
}
|
||||
|
||||
@ -65,10 +67,14 @@ data Result a
|
||||
data Details
|
||||
= Details V.Version (Map.Map Pkg.Name C.Constraint)
|
||||
|
||||
verify :: Dirs.PackageCache -> Map.Map Pkg.Name C.Constraint -> IO (Result (Map.Map Pkg.Name Details))
|
||||
verify cache constraints =
|
||||
verify ::
|
||||
Dirs.PackageCache ->
|
||||
Platform.Platform ->
|
||||
Map.Map Pkg.Name C.Constraint ->
|
||||
IO (Result (Map.Map Pkg.Name Details))
|
||||
verify cache rootPlatform constraints =
|
||||
Dirs.withRegistryLock cache $
|
||||
case try constraints of
|
||||
case try rootPlatform constraints of
|
||||
Solver solver ->
|
||||
solver
|
||||
(State cache Map.empty)
|
||||
@ -79,7 +85,7 @@ verify cache constraints =
|
||||
addDeps :: State -> Pkg.Name -> V.Version -> Details
|
||||
addDeps (State _ constraints) name vsn =
|
||||
case Map.lookup (name, vsn) constraints of
|
||||
Just (Constraints _ deps) -> Details vsn deps
|
||||
Just (Constraints _ _ deps) -> Details vsn deps
|
||||
Nothing -> error "compiler bug manifesting in Deps.Solver.addDeps"
|
||||
|
||||
-- ADD TO APP - used in Install
|
||||
@ -90,21 +96,25 @@ data AppSolution = AppSolution
|
||||
_app :: Outline.AppOutline
|
||||
}
|
||||
|
||||
addToApp :: Dirs.PackageCache -> Pkg.Name -> Outline.AppOutline -> IO (Result AppSolution)
|
||||
addToApp cache pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
|
||||
addToApp ::
|
||||
Dirs.PackageCache ->
|
||||
Pkg.Name ->
|
||||
V.Version ->
|
||||
Outline.AppOutline ->
|
||||
IO (Result AppSolution)
|
||||
addToApp cache pkg compatibleVsn outline@(Outline.AppOutline _ rootPlatform _ direct indirect) =
|
||||
Dirs.withRegistryLock cache $
|
||||
let allIndirects = Map.union indirect testIndirect
|
||||
allDirects = Map.union direct testDirect
|
||||
allDeps = Map.union allDirects allIndirects
|
||||
let allDeps = Map.union direct indirect
|
||||
|
||||
attempt toConstraint deps =
|
||||
try (Map.insert pkg C.anything (Map.map toConstraint deps))
|
||||
try
|
||||
rootPlatform
|
||||
(Map.insert pkg (C.untilNextMajor compatibleVsn) (Map.map toConstraint deps))
|
||||
in case oneOf
|
||||
(attempt C.exactly allDeps)
|
||||
[ attempt C.exactly allDirects,
|
||||
attempt C.untilNextMinor allDirects,
|
||||
attempt C.untilNextMajor allDirects,
|
||||
attempt (\_ -> C.anything) allDirects
|
||||
[ attempt C.exactly direct,
|
||||
attempt C.untilNextMinor direct,
|
||||
attempt C.untilNextMajor direct
|
||||
] of
|
||||
Solver solver ->
|
||||
solver
|
||||
@ -114,12 +124,10 @@ addToApp cache pkg outline@(Outline.AppOutline _ _ direct indirect testDirect te
|
||||
(\e -> return $ Err e)
|
||||
|
||||
toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version -> AppSolution
|
||||
toApp (State _ constraints) pkg (Outline.AppOutline gren srcDirs direct _ testDirect _) old new =
|
||||
toApp (State _ constraints) pkg (Outline.AppOutline gren platform srcDirs direct _) old new =
|
||||
let d = Map.intersection new (Map.insert pkg V.one direct)
|
||||
i = Map.difference (getTransitive constraints new (Map.toList d) Map.empty) d
|
||||
td = Map.intersection new (Map.delete pkg testDirect)
|
||||
ti = Map.difference new (Map.unions [d, i, td])
|
||||
in AppSolution old new (Outline.AppOutline gren srcDirs d i td ti)
|
||||
in AppSolution old new (Outline.AppOutline gren platform srcDirs d i)
|
||||
|
||||
getTransitive :: Map.Map (Pkg.Name, V.Version) Constraints -> Map.Map Pkg.Name V.Version -> [(Pkg.Name, V.Version)] -> Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name V.Version
|
||||
getTransitive constraints solution unvisited visited =
|
||||
@ -138,38 +146,38 @@ getTransitive constraints solution unvisited visited =
|
||||
|
||||
-- TRY
|
||||
|
||||
try :: Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try constraints =
|
||||
exploreGoals (Goals constraints Map.empty)
|
||||
try :: Platform.Platform -> Map.Map Pkg.Name C.Constraint -> Solver (Map.Map Pkg.Name V.Version)
|
||||
try rootPlatform constraints =
|
||||
exploreGoals (Goals rootPlatform constraints Map.empty)
|
||||
|
||||
-- EXPLORE GOALS
|
||||
|
||||
data Goals = Goals
|
||||
{ _pending :: Map.Map Pkg.Name C.Constraint,
|
||||
{ _root_platform :: Platform.Platform,
|
||||
_pending :: Map.Map Pkg.Name C.Constraint,
|
||||
_solved :: Map.Map Pkg.Name V.Version
|
||||
}
|
||||
|
||||
exploreGoals :: Goals -> Solver (Map.Map Pkg.Name V.Version)
|
||||
exploreGoals (Goals pending solved) =
|
||||
exploreGoals (Goals rootPlatform pending solved) =
|
||||
case Map.minViewWithKey pending of
|
||||
Nothing ->
|
||||
return solved
|
||||
Just ((name, constraint), otherPending) ->
|
||||
do
|
||||
let goals1 = Goals otherPending solved
|
||||
let addVsn = addVersion goals1 name
|
||||
(v, vs) <- getRelevantVersions name constraint
|
||||
goals2 <- oneOf (addVsn v) (map addVsn vs)
|
||||
let goals1 = Goals rootPlatform otherPending solved
|
||||
let lowestVersion = C.lowerBound constraint
|
||||
goals2 <- addVersion goals1 name lowestVersion
|
||||
exploreGoals goals2
|
||||
|
||||
addVersion :: Goals -> Pkg.Name -> V.Version -> Solver Goals
|
||||
addVersion (Goals pending solved) name version =
|
||||
addVersion (Goals rootPlatform pending solved) name version =
|
||||
do
|
||||
(Constraints gren deps) <- getConstraints name version
|
||||
if C.goodGren gren
|
||||
(Constraints gren platform deps) <- getConstraints name version
|
||||
if C.goodGren gren && Platform.compatible rootPlatform platform
|
||||
then do
|
||||
newPending <- foldM (addConstraint solved) pending (Map.toList deps)
|
||||
return (Goals newPending (Map.insert name version solved))
|
||||
return (Goals rootPlatform newPending (Map.insert name version solved))
|
||||
else backtrack
|
||||
|
||||
addConstraint :: Map.Map Pkg.Name V.Version -> Map.Map Pkg.Name C.Constraint -> (Pkg.Name, C.Constraint) -> Solver (Map.Map Pkg.Name C.Constraint)
|
||||
@ -192,20 +200,6 @@ addConstraint solved unsolved (name, newConstraint) =
|
||||
then return unsolved
|
||||
else return (Map.insert name mergedConstraint unsolved)
|
||||
|
||||
-- GET RELEVANT VERSIONS
|
||||
|
||||
getRelevantVersions :: Pkg.Name -> C.Constraint -> Solver (V.Version, [V.Version])
|
||||
getRelevantVersions name constraint =
|
||||
Solver $ \state@(State cache _) ok back err -> do
|
||||
versionsResult <- Package.getVersions cache name
|
||||
case versionsResult of
|
||||
Right (newest, previous) ->
|
||||
case filter (C.satisfies constraint) (newest : previous) of
|
||||
[] -> back state
|
||||
v : vs -> ok state (v, vs) back
|
||||
Left gitErr ->
|
||||
err $ Exit.SolverBadGitOperationUnversionedPkg name gitErr
|
||||
|
||||
-- GET CONSTRAINTS
|
||||
|
||||
getConstraints :: Pkg.Name -> V.Version -> Solver Constraints
|
||||
@ -242,8 +236,8 @@ constraintsDecoder =
|
||||
do
|
||||
outline <- D.mapError (const ()) Outline.decoder
|
||||
case outline of
|
||||
Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps _ grenConstraint) ->
|
||||
return (Constraints grenConstraint deps)
|
||||
Outline.Pkg (Outline.PkgOutline _ _ _ _ _ deps grenConstraint platform) ->
|
||||
return (Constraints grenConstraint platform deps)
|
||||
Outline.App _ ->
|
||||
D.failure ()
|
||||
|
||||
|
@ -14,20 +14,19 @@ module Directories
|
||||
PackageCache,
|
||||
getPackageCache,
|
||||
package,
|
||||
basePackage,
|
||||
getReplCache,
|
||||
getGrenHome,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified System.Directory as Dir
|
||||
import qualified System.Environment as Env
|
||||
import qualified System.FileLock as Lock
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import System.Directory qualified as Dir
|
||||
import System.Environment qualified as Env
|
||||
import System.FileLock qualified as Lock
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import qualified System.FilePath as FP
|
||||
import System.FilePath qualified as FP
|
||||
|
||||
-- PATHS
|
||||
|
||||
@ -120,10 +119,6 @@ package :: PackageCache -> Pkg.Name -> V.Version -> FilePath
|
||||
package (PackageCache dir) name version =
|
||||
dir </> Pkg.toFilePath name </> V.toChars version
|
||||
|
||||
basePackage :: PackageCache -> Pkg.Name -> FilePath
|
||||
basePackage (PackageCache dir) name =
|
||||
dir </> Pkg.toFilePath name </> "repo.git"
|
||||
|
||||
-- CACHE
|
||||
|
||||
getReplCache :: IO FilePath
|
||||
|
@ -14,19 +14,19 @@ module File
|
||||
where
|
||||
|
||||
import Control.Exception (catch)
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.ByteString.Internal as BS
|
||||
import qualified Data.Fixed as Fixed
|
||||
import qualified Data.Time.Clock as Time
|
||||
import qualified Data.Time.Clock.POSIX as Time
|
||||
import qualified Foreign.ForeignPtr as FPtr
|
||||
import Data.Binary qualified as Binary
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.ByteString.Internal qualified as BS
|
||||
import Data.Fixed qualified as Fixed
|
||||
import Data.Time.Clock qualified as Time
|
||||
import Data.Time.Clock.POSIX qualified as Time
|
||||
import Foreign.ForeignPtr qualified as FPtr
|
||||
import GHC.IO.Exception (IOErrorType (InvalidArgument), IOException)
|
||||
import qualified System.Directory as Dir
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ()
|
||||
import qualified System.FilePath as FP
|
||||
import qualified System.IO as IO
|
||||
import System.FilePath qualified as FP
|
||||
import System.IO qualified as IO
|
||||
import System.IO.Error (annotateIOError, ioeGetErrorType, modifyIOError)
|
||||
|
||||
-- TIME
|
||||
|
@ -8,34 +8,30 @@ module Generate
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Build
|
||||
import AST.Optimized qualified as Opt
|
||||
import Build qualified
|
||||
import Control.Concurrent (MVar, forkIO, newEmptyMVar, newMVar, putMVar, readMVar)
|
||||
import Control.Monad (liftM2)
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as N
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Directories as Dirs
|
||||
import qualified File
|
||||
import qualified Generate.JavaScript as JS
|
||||
import qualified Generate.Mode as Mode
|
||||
import qualified Gren.Compiler.Type.Extract as Extract
|
||||
import qualified Gren.Details as Details
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Nitpick.Debug as Nitpick
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified Reporting.Task as Task
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as N
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Generate.JavaScript qualified as JS
|
||||
import Generate.Mode qualified as Mode
|
||||
import Gren.Compiler.Type.Extract qualified as Extract
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Nitpick.Debug qualified as Nitpick
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Task qualified as Task
|
||||
import Prelude hiding (cycle, print)
|
||||
|
||||
-- NOTE: This is used by Make, Repl, and Reactor right now. But it may be
|
||||
-- desireable to have Repl and Reactor to keep foreign objects in memory
|
||||
-- to make things a bit faster?
|
||||
|
||||
-- GENERATORS
|
||||
|
||||
type Task a =
|
||||
|
@ -4,8 +4,6 @@ module Git
|
||||
--
|
||||
githubUrl,
|
||||
clone,
|
||||
localClone,
|
||||
update,
|
||||
tags,
|
||||
--
|
||||
hasLocalTag,
|
||||
@ -13,21 +11,25 @@ module Git
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Either as Either
|
||||
import qualified Data.List as List
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Parse.Primitives as Parser
|
||||
import Data.Either qualified as Either
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Parse.Primitives qualified as Parser
|
||||
import System.Directory (findExecutable)
|
||||
import qualified System.Exit as Exit
|
||||
import qualified System.IO as IO
|
||||
import qualified System.Process as Process
|
||||
import System.Exit qualified as Exit
|
||||
import System.IO qualified as IO
|
||||
import System.Process qualified as Process
|
||||
|
||||
data Error
|
||||
= MissingGit
|
||||
| FailedCommand (Maybe FilePath) [String] String
|
||||
| NoVersions FilePath
|
||||
| NoVersions
|
||||
| NoSuchRepo
|
||||
| NoSuchRepoOrVersion V.Version
|
||||
| FailedCommand [String] String
|
||||
|
||||
--
|
||||
|
||||
@ -53,43 +55,21 @@ githubUrl pkg =
|
||||
|
||||
--
|
||||
|
||||
clone :: GitUrl -> FilePath -> IO (Either Error ())
|
||||
clone (GitUrl (pkgName, gitUrl)) targetFolder = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Cloning " ++ pkgName ++ "... "
|
||||
case maybeExec of
|
||||
Nothing -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["clone", "--bare", gitUrl, targetFolder]
|
||||
(exitCode, _, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
(Process.proc git args)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
Exit.ExitSuccess -> do
|
||||
putStrLn "Ok!"
|
||||
return $ Right ()
|
||||
|
||||
localClone :: FilePath -> V.Version -> FilePath -> IO (Either Error ())
|
||||
localClone gitUrl vsn targetFolder = do
|
||||
clone :: GitUrl -> V.Version -> FilePath -> IO (Either Error ())
|
||||
clone (GitUrl (pkgName, gitUrl)) vsn targetFolder = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Cloning " ++ pkgName ++ " " ++ V.toChars vsn ++ "... "
|
||||
case maybeExec of
|
||||
Nothing ->
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args =
|
||||
[ "clone",
|
||||
gitUrl,
|
||||
"--local",
|
||||
"-b",
|
||||
"--branch",
|
||||
V.toChars vsn,
|
||||
"--depth",
|
||||
"1",
|
||||
gitUrl,
|
||||
targetFolder
|
||||
]
|
||||
(exitCode, _, stderr) <-
|
||||
@ -97,65 +77,70 @@ localClone gitUrl vsn targetFolder = do
|
||||
(Process.proc git args)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure 128 -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ NoSuchRepoOrVersion vsn
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
return $ Right ()
|
||||
|
||||
update :: Pkg.Name -> FilePath -> IO (Either Error ())
|
||||
update pkg path = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Updating " ++ Pkg.toChars pkg ++ "... "
|
||||
case maybeExec of
|
||||
Nothing -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["fetch", "-t"]
|
||||
(exitCode, _, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
( (Process.proc git args)
|
||||
{ Process.cwd = Just path
|
||||
}
|
||||
)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
|
||||
return $ Left $ FailedCommand ("git" : args) stderr
|
||||
Exit.ExitSuccess -> do
|
||||
putStrLn "Ok!"
|
||||
return $ Right ()
|
||||
|
||||
tags :: FilePath -> IO (Either Error (V.Version, [V.Version]))
|
||||
tags path = do
|
||||
tags :: GitUrl -> IO (Either Error (V.Version, [V.Version]))
|
||||
tags (GitUrl (pkgName, gitUrl)) = do
|
||||
maybeExec <- checkInstalledGit
|
||||
putStrFlush $ "Retrieving versions for " ++ pkgName ++ "... "
|
||||
case maybeExec of
|
||||
Nothing ->
|
||||
return $ Left MissingGit
|
||||
Just git -> do
|
||||
let args = ["tag"]
|
||||
let args =
|
||||
[ "ls-remote",
|
||||
"--tags",
|
||||
gitUrl
|
||||
]
|
||||
(exitCode, stdout, stderr) <-
|
||||
Process.readCreateProcessWithExitCode
|
||||
( (Process.proc git args)
|
||||
{ Process.cwd = Just path
|
||||
}
|
||||
)
|
||||
(Process.proc git args)
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure 128 -> do
|
||||
putStrLn "Error!"
|
||||
return $ Left NoSuchRepo
|
||||
Exit.ExitFailure _ -> do
|
||||
return $ Left $ FailedCommand (Just path) ("git" : args) stderr
|
||||
putStrLn "Error!"
|
||||
return $ Left $ FailedCommand ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
let tagList =
|
||||
map BS.pack $ lines stdout
|
||||
map (TE.encodeUtf8) $
|
||||
map (Text.replace (Text.pack "refs/tags/") Text.empty) $
|
||||
map (Text.pack) $
|
||||
map (Maybe.fromMaybe "" . listGet 1) $
|
||||
map words $
|
||||
lines stdout
|
||||
|
||||
-- Ignore tags that aren't semantic versions
|
||||
versions =
|
||||
reverse $ List.sort $ Either.rights $ map (Parser.fromByteString V.parser (,)) tagList
|
||||
in case versions of
|
||||
[] -> return $ Left $ NoVersions path
|
||||
v : vs -> return $ Right (v, vs)
|
||||
reverse $
|
||||
List.sort $
|
||||
Either.rights $ -- Ignore tags that aren't semantic versions
|
||||
map (Parser.fromByteString V.parser (,)) tagList
|
||||
in do
|
||||
putStrLn "Ok!"
|
||||
return $ case versions of
|
||||
[] -> Left NoVersions
|
||||
v : vs -> Right (v, vs)
|
||||
|
||||
listGet :: Int -> [a] -> Maybe a
|
||||
listGet idx ls =
|
||||
case ls of
|
||||
[] -> Nothing
|
||||
first : rest ->
|
||||
if idx == 0
|
||||
then Just first
|
||||
else listGet (idx - 1) rest
|
||||
|
||||
--
|
||||
|
||||
hasLocalTag :: V.Version -> IO (Either Error ())
|
||||
hasLocalTag vsn = do
|
||||
@ -171,7 +156,7 @@ hasLocalTag vsn = do
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
return $ Left $ FailedCommand ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
return $ Right ()
|
||||
|
||||
@ -189,6 +174,6 @@ hasLocalChangesSinceTag vsn = do
|
||||
""
|
||||
case exitCode of
|
||||
Exit.ExitFailure _ -> do
|
||||
return $ Left $ FailedCommand Nothing ("git" : args) stderr
|
||||
return $ Left $ FailedCommand ("git" : args) stderr
|
||||
Exit.ExitSuccess ->
|
||||
return $ Right ()
|
||||
|
@ -14,42 +14,43 @@ module Gren.Details
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Source as Src
|
||||
import qualified BackgroundWriter as BW
|
||||
import qualified Compile
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Source qualified as Src
|
||||
import BackgroundWriter qualified as BW
|
||||
import Compile qualified
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
|
||||
import Control.Monad (liftM, liftM2, liftM3)
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Data.Either as Either
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Merge.Strict as Map
|
||||
import qualified Data.Map.Utils as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified Data.Set as Set
|
||||
import Data.Either qualified as Either
|
||||
import Data.Map qualified as Map
|
||||
import Data.Map.Merge.Strict qualified as Map
|
||||
import Data.Map.Utils qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Data.Set qualified as Set
|
||||
import Data.Word (Word64)
|
||||
import qualified Deps.Solver as Solver
|
||||
import qualified Directories as Dirs
|
||||
import qualified File
|
||||
import qualified Gren.Constraint as Con
|
||||
import qualified Gren.Docs as Docs
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.Kernel as Kernel
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Outline as Outline
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Encode as E
|
||||
import qualified Parse.Module as Parse
|
||||
import qualified Reporting
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified Reporting.Task as Task
|
||||
import Deps.Solver qualified as Solver
|
||||
import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Gren.Constraint qualified as Con
|
||||
import Gren.Docs qualified as Docs
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.Kernel qualified as Kernel
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Module qualified as Parse
|
||||
import Reporting qualified
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Task qualified as Task
|
||||
import System.FilePath ((<.>), (</>))
|
||||
|
||||
-- DETAILS
|
||||
@ -67,7 +68,7 @@ type BuildID = Word64
|
||||
|
||||
data ValidOutline
|
||||
= ValidApp (NE.List Outline.SrcDir)
|
||||
| ValidPkg Pkg.Name [ModuleName.Raw] (Map.Map Pkg.Name V.Version {- for docs in reactor -})
|
||||
| ValidPkg Pkg.Name [ModuleName.Raw]
|
||||
|
||||
-- NOTE: we need two ways to detect if a file must be recompiled:
|
||||
--
|
||||
@ -127,7 +128,7 @@ verifyInstall scope root (Solver.Env cache) outline =
|
||||
Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ())
|
||||
Outline.App app -> Task.run (verifyApp env time app >> return ())
|
||||
|
||||
-- LOAD -- used by Make, Repl, Reactor
|
||||
-- LOAD -- used by Make, Repl
|
||||
|
||||
load :: Reporting.Style -> BW.Scope -> FilePath -> IO (Either Exit.Details Details)
|
||||
load style scope root =
|
||||
@ -184,39 +185,39 @@ initEnv key scope root =
|
||||
type Task a = Task.Task Exit.Details a
|
||||
|
||||
verifyPkg :: Env -> File.Time -> Outline.PkgOutline -> Task Details
|
||||
verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct testDirect gren) =
|
||||
verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct gren rootPlatform) =
|
||||
if Con.goodGren gren
|
||||
then do
|
||||
solution <- verifyConstraints env =<< union noDups direct testDirect
|
||||
solution <- verifyConstraints env rootPlatform (Map.map (Con.exactly . Con.lowerBound) direct)
|
||||
let exposedList = Outline.flattenExposed exposed
|
||||
let exactDeps = Map.map (\(Solver.Details v _) -> v) solution -- for pkg docs in reactor
|
||||
verifyDependencies env time (ValidPkg pkg exposedList exactDeps) solution direct
|
||||
verifyDependencies env time (ValidPkg pkg exposedList) solution direct
|
||||
else Task.throw $ Exit.DetailsBadGrenInPkg gren
|
||||
|
||||
verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
|
||||
verifyApp env time outline@(Outline.AppOutline grenVersion srcDirs direct _ _ _) =
|
||||
verifyApp env time outline@(Outline.AppOutline grenVersion rootPlatform srcDirs direct _) =
|
||||
if grenVersion == V.compiler
|
||||
then do
|
||||
stated <- checkAppDeps outline
|
||||
actual <- verifyConstraints env (Map.map Con.exactly stated)
|
||||
actual <- verifyConstraints env rootPlatform (Map.map Con.exactly stated)
|
||||
if Map.size stated == Map.size actual
|
||||
then verifyDependencies env time (ValidApp srcDirs) actual direct
|
||||
else Task.throw Exit.DetailsHandEditedDependencies
|
||||
else Task.throw $ Exit.DetailsBadGrenInAppOutline grenVersion
|
||||
|
||||
checkAppDeps :: Outline.AppOutline -> Task (Map.Map Pkg.Name V.Version)
|
||||
checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect) =
|
||||
do
|
||||
x <- union allowEqualDups indirect testDirect
|
||||
y <- union noDups direct testIndirect
|
||||
union noDups x y
|
||||
checkAppDeps (Outline.AppOutline _ _ _ direct indirect) =
|
||||
union noDups direct indirect
|
||||
|
||||
-- VERIFY CONSTRAINTS
|
||||
|
||||
verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details)
|
||||
verifyConstraints (Env _ _ _ cache) constraints =
|
||||
verifyConstraints ::
|
||||
Env ->
|
||||
Platform.Platform ->
|
||||
Map.Map Pkg.Name Con.Constraint ->
|
||||
Task (Map.Map Pkg.Name Solver.Details)
|
||||
verifyConstraints (Env _ _ _ cache) rootPlatform constraints =
|
||||
do
|
||||
result <- Task.io $ Solver.verify cache constraints
|
||||
result <- Task.io $ Solver.verify cache rootPlatform constraints
|
||||
case result of
|
||||
Solver.Ok details -> return details
|
||||
Solver.NoSolution -> Task.throw $ Exit.DetailsNoSolution
|
||||
@ -233,12 +234,6 @@ noDups :: k -> v -> v -> Task v
|
||||
noDups _ _ _ =
|
||||
Task.throw Exit.DetailsHandEditedDependencies
|
||||
|
||||
allowEqualDups :: (Eq v) => k -> v -> v -> Task v
|
||||
allowEqualDups _ v1 v2 =
|
||||
if v1 == v2
|
||||
then return v1
|
||||
else Task.throw Exit.DetailsHandEditedDependencies
|
||||
|
||||
-- FORK
|
||||
|
||||
fork :: IO a -> IO (MVar a)
|
||||
@ -268,7 +263,9 @@ verifyDependencies env@(Env key scope root cache) time outline solution directDe
|
||||
return $
|
||||
Left $
|
||||
Exit.DetailsBadDeps home $
|
||||
Maybe.catMaybes $ Either.lefts $ Map.elems deps
|
||||
Maybe.catMaybes $
|
||||
Either.lefts $
|
||||
Map.elems deps
|
||||
Right artifacts ->
|
||||
let objs = Map.foldr addObjects Opt.empty artifacts
|
||||
ifaces = Map.foldrWithKey (addInterfaces directDeps) Map.empty artifacts
|
||||
@ -600,7 +597,8 @@ writeDocs cache pkg vsn status results =
|
||||
case status of
|
||||
DocsNeeded ->
|
||||
E.writeUgly (Dirs.package cache pkg vsn </> "docs.json") $
|
||||
Docs.encode $ Map.mapMaybe toDocs results
|
||||
Docs.encode $
|
||||
Map.mapMaybe toDocs results
|
||||
DocsNotNeeded ->
|
||||
return ()
|
||||
|
||||
@ -629,14 +627,14 @@ instance Binary ValidOutline where
|
||||
put outline =
|
||||
case outline of
|
||||
ValidApp a -> putWord8 0 >> put a
|
||||
ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
|
||||
ValidPkg a b -> putWord8 1 >> put a >> put b
|
||||
|
||||
get =
|
||||
do
|
||||
n <- getWord8
|
||||
case n of
|
||||
0 -> liftM ValidApp get
|
||||
1 -> liftM3 ValidPkg get get get
|
||||
1 -> liftM2 ValidPkg get get
|
||||
_ -> fail "binary encoding of ValidOutline was corrupted"
|
||||
|
||||
instance Binary Local where
|
||||
|
@ -21,28 +21,29 @@ module Gren.Outline
|
||||
where
|
||||
|
||||
import AbsoluteSrcDir (AbsoluteSrcDir)
|
||||
import qualified AbsoluteSrcDir
|
||||
import AbsoluteSrcDir qualified
|
||||
import Control.Monad (filterM, liftM)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified File
|
||||
import Data.Map qualified as Map
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import File qualified
|
||||
import Foreign.Ptr (minusPtr)
|
||||
import qualified Gren.Constraint as Con
|
||||
import qualified Gren.Licenses as Licenses
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as D
|
||||
import Gren.Constraint qualified as Con
|
||||
import Gren.Licenses qualified as Licenses
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified System.Directory as Dir
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Exit qualified as Exit
|
||||
import System.Directory qualified as Dir
|
||||
import System.FilePath ((</>))
|
||||
import qualified System.FilePath as FP
|
||||
import System.FilePath qualified as FP
|
||||
import Prelude hiding (read)
|
||||
|
||||
-- OUTLINE
|
||||
@ -53,11 +54,10 @@ data Outline
|
||||
|
||||
data AppOutline = AppOutline
|
||||
{ _app_gren_version :: V.Version,
|
||||
_app_platform :: Platform.Platform,
|
||||
_app_source_dirs :: NE.List SrcDir,
|
||||
_app_deps_direct :: Map.Map Pkg.Name V.Version,
|
||||
_app_deps_indirect :: Map.Map Pkg.Name V.Version,
|
||||
_app_test_direct :: Map.Map Pkg.Name V.Version,
|
||||
_app_test_indirect :: Map.Map Pkg.Name V.Version
|
||||
_app_deps_indirect :: Map.Map Pkg.Name V.Version
|
||||
}
|
||||
|
||||
data PkgOutline = PkgOutline
|
||||
@ -67,8 +67,8 @@ data PkgOutline = PkgOutline
|
||||
_pkg_version :: V.Version,
|
||||
_pkg_exposed :: Exposed,
|
||||
_pkg_deps :: Map.Map Pkg.Name Con.Constraint,
|
||||
_pkg_test_deps :: Map.Map Pkg.Name Con.Constraint,
|
||||
_pkg_gren_version :: Con.Constraint
|
||||
_pkg_gren_version :: Con.Constraint,
|
||||
_pkg_platform :: Platform.Platform
|
||||
}
|
||||
|
||||
data Exposed
|
||||
@ -106,33 +106,29 @@ write root outline =
|
||||
encode :: Outline -> E.Value
|
||||
encode outline =
|
||||
case outline of
|
||||
App (AppOutline gren srcDirs depsDirect depsTrans testDirect testTrans) ->
|
||||
App (AppOutline gren platform srcDirs depsDirect depsTrans) ->
|
||||
E.object
|
||||
[ "type" ==> E.chars "application",
|
||||
"platform" ==> Platform.encode platform,
|
||||
"source-directories" ==> E.list encodeSrcDir (NE.toList srcDirs),
|
||||
"gren-version" ==> V.encode gren,
|
||||
"dependencies"
|
||||
==> E.object
|
||||
[ "direct" ==> encodeDeps V.encode depsDirect,
|
||||
"indirect" ==> encodeDeps V.encode depsTrans
|
||||
],
|
||||
"test-dependencies"
|
||||
==> E.object
|
||||
[ "direct" ==> encodeDeps V.encode testDirect,
|
||||
"indirect" ==> encodeDeps V.encode testTrans
|
||||
]
|
||||
]
|
||||
Pkg (PkgOutline name summary license version exposed deps tests gren) ->
|
||||
Pkg (PkgOutline name summary license version exposed deps gren platform) ->
|
||||
E.object
|
||||
[ "type" ==> E.string (Json.fromChars "package"),
|
||||
"platform" ==> Platform.encode platform,
|
||||
"name" ==> Pkg.encode name,
|
||||
"summary" ==> E.string summary,
|
||||
"license" ==> Licenses.encode license,
|
||||
"version" ==> V.encode version,
|
||||
"exposed-modules" ==> encodeExposed exposed,
|
||||
"gren-version" ==> Con.encode gren,
|
||||
"dependencies" ==> encodeDeps Con.encode deps,
|
||||
"test-dependencies" ==> encodeDeps Con.encode tests
|
||||
"dependencies" ==> encodeDeps Con.encode deps
|
||||
]
|
||||
|
||||
encodeExposed :: Exposed -> E.Value
|
||||
@ -173,11 +169,9 @@ read root =
|
||||
if Map.notMember Pkg.core deps && pkg /= Pkg.core
|
||||
then Left Exit.OutlineNoPkgCore
|
||||
else Right outline
|
||||
App (AppOutline _ srcDirs direct indirect _ _)
|
||||
App (AppOutline _ _ srcDirs direct _)
|
||||
| Map.notMember Pkg.core direct ->
|
||||
return $ Left Exit.OutlineNoAppCore
|
||||
| Map.notMember Pkg.json direct && Map.notMember Pkg.json indirect ->
|
||||
return $ Left Exit.OutlineNoAppJson
|
||||
| otherwise ->
|
||||
do
|
||||
badDirs <- filterM (isSrcDirMissing root) (NE.toList srcDirs)
|
||||
@ -237,7 +231,7 @@ isDup paths =
|
||||
sourceDirs :: Outline -> NE.List SrcDir
|
||||
sourceDirs outline =
|
||||
case outline of
|
||||
App (AppOutline _ srcDirs _ _ _ _) ->
|
||||
App (AppOutline _ _ srcDirs _ _) ->
|
||||
srcDirs
|
||||
Pkg _ ->
|
||||
NE.singleton (RelativeSrcDir "src")
|
||||
@ -266,11 +260,10 @@ appDecoder :: Decoder AppOutline
|
||||
appDecoder =
|
||||
AppOutline
|
||||
<$> D.field "gren-version" versionDecoder
|
||||
<*> D.field "platform" Platform.decoder
|
||||
<*> D.field "source-directories" dirsDecoder
|
||||
<*> D.field "dependencies" (D.field "direct" (depsDecoder versionDecoder))
|
||||
<*> D.field "dependencies" (D.field "indirect" (depsDecoder versionDecoder))
|
||||
<*> D.field "test-dependencies" (D.field "direct" (depsDecoder versionDecoder))
|
||||
<*> D.field "test-dependencies" (D.field "indirect" (depsDecoder versionDecoder))
|
||||
|
||||
pkgDecoder :: Decoder PkgOutline
|
||||
pkgDecoder =
|
||||
@ -281,8 +274,8 @@ pkgDecoder =
|
||||
<*> D.field "version" versionDecoder
|
||||
<*> D.field "exposed-modules" exposedDecoder
|
||||
<*> D.field "dependencies" (depsDecoder constraintDecoder)
|
||||
<*> D.field "test-dependencies" (depsDecoder constraintDecoder)
|
||||
<*> D.field "gren-version" constraintDecoder
|
||||
<*> D.field "platform" Platform.decoder
|
||||
|
||||
-- JSON DECODE HELPERS
|
||||
|
||||
|
52
builder/src/Gren/Platform.hs
Normal file
52
builder/src/Gren/Platform.hs
Normal file
@ -0,0 +1,52 @@
|
||||
module Gren.Platform
|
||||
( Platform (..),
|
||||
--
|
||||
compatible,
|
||||
--
|
||||
encode,
|
||||
decoder,
|
||||
fromString,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Reporting.Exit qualified as Exit
|
||||
|
||||
data Platform
|
||||
= Common
|
||||
| Browser
|
||||
| Node
|
||||
deriving (Eq)
|
||||
|
||||
-- COMPATIBILITY
|
||||
|
||||
compatible :: Platform -> Platform -> Bool
|
||||
compatible rootPlatform comparison =
|
||||
rootPlatform == comparison || comparison == Common
|
||||
|
||||
-- JSON
|
||||
|
||||
encode :: Platform -> E.Value
|
||||
encode platform =
|
||||
case platform of
|
||||
Common -> E.chars "common"
|
||||
Browser -> E.chars "browser"
|
||||
Node -> E.chars "node"
|
||||
|
||||
decoder :: D.Decoder Exit.OutlineProblem Platform
|
||||
decoder =
|
||||
do
|
||||
platformStr <- D.string
|
||||
case fromString $ Utf8.toChars platformStr of
|
||||
Just platform -> D.succeed platform
|
||||
Nothing -> D.failure Exit.OP_BadPlatform
|
||||
|
||||
fromString :: String -> Maybe Platform
|
||||
fromString value =
|
||||
case value of
|
||||
"common" -> Just Common
|
||||
"browser" -> Just Browser
|
||||
"node" -> Just Node
|
||||
_ -> Nothing
|
@ -32,19 +32,19 @@ where
|
||||
import Control.Concurrent
|
||||
import Control.Exception (AsyncException (UserInterrupt), SomeException, catch, fromException, throw)
|
||||
import Control.Monad (when)
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Encode as Encode
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode qualified as Encode
|
||||
import Reporting.Doc ((<+>))
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Exit as Exit
|
||||
import qualified Reporting.Exit.Help as Help
|
||||
import qualified System.Exit as Exit
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Exit.Help qualified as Help
|
||||
import System.Exit qualified as Exit
|
||||
import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
|
||||
import qualified System.Info as Info
|
||||
import System.Info qualified as Info
|
||||
|
||||
-- STYLE
|
||||
|
||||
@ -238,7 +238,7 @@ putDownload mark pkg vsn =
|
||||
mark
|
||||
<+> D.fromPackage pkg
|
||||
<+> D.fromVersion vsn
|
||||
<> "\n"
|
||||
<> "\n"
|
||||
|
||||
putTransition :: DState -> IO DState
|
||||
putTransition state@(DState total cached _ rcvd failed built broken) =
|
||||
@ -253,7 +253,8 @@ putBuilt :: DState -> IO DState
|
||||
putBuilt state@(DState total cached _ rcvd failed built broken) =
|
||||
do
|
||||
when (total == cached + rcvd + failed) $
|
||||
putStrFlush $ '\r' : toBuildProgress (built + broken + failed) total
|
||||
putStrFlush $
|
||||
'\r' : toBuildProgress (built + broken + failed) total
|
||||
return state
|
||||
|
||||
toBuildProgress :: Int -> Int -> [Char]
|
||||
@ -353,8 +354,8 @@ toGenDiagram (NE.List name names) output =
|
||||
toGenLine width name ('>' : ' ' : output ++ "\n")
|
||||
_ : _ ->
|
||||
unlines $
|
||||
toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output) :
|
||||
reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
|
||||
toGenLine width name (vtop : hbar : hbar : '>' : ' ' : output)
|
||||
: reverse (zipWith (toGenLine width) (reverse names) ([vbottom] : repeat [vmiddle]))
|
||||
|
||||
toGenLine :: Int -> [Char] -> [Char] -> [Char]
|
||||
toGenLine width name end =
|
||||
|
@ -15,8 +15,6 @@ module Reporting.Exit
|
||||
publishToReport,
|
||||
Install (..),
|
||||
installToReport,
|
||||
Reactor (..),
|
||||
reactorToReport,
|
||||
Format (..),
|
||||
formatToReport,
|
||||
newPackageOverview,
|
||||
@ -37,32 +35,32 @@ module Reporting.Exit
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.UTF8 as BS_UTF8
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as N
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified File
|
||||
import qualified Git
|
||||
import qualified Gren.Constraint as C
|
||||
import qualified Gren.Magnitude as M
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as Decode
|
||||
import qualified Json.Encode as Encode
|
||||
import qualified Json.String as Json
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.UTF8 qualified as BS_UTF8
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as N
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import File qualified
|
||||
import Git qualified
|
||||
import Gren.Constraint qualified as C
|
||||
import Gren.Magnitude qualified as M
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as Decode
|
||||
import Json.Encode qualified as Encode
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Error as Error
|
||||
import qualified Reporting.Error.Import as Import
|
||||
import qualified Reporting.Error.Json as Json
|
||||
import qualified Reporting.Exit.Help as Help
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Error qualified as Error
|
||||
import Reporting.Error.Import qualified as Import
|
||||
import Reporting.Error.Json qualified as Json
|
||||
import Reporting.Exit.Help qualified as Help
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import System.FilePath ((<.>), (</>))
|
||||
import qualified System.FilePath as FP
|
||||
import System.FilePath qualified as FP
|
||||
|
||||
-- RENDERERS
|
||||
|
||||
@ -85,6 +83,7 @@ data Init
|
||||
| InitNoOfflineSolution [Pkg.Name]
|
||||
| InitSolverProblem Solver
|
||||
| InitAlreadyExists
|
||||
| InitNoCompatibleDependencies (Maybe Git.Error)
|
||||
|
||||
initToReport :: Init -> Help.Report
|
||||
initToReport exit =
|
||||
@ -137,6 +136,20 @@ initToReport exit =
|
||||
"next?"
|
||||
]
|
||||
]
|
||||
InitNoCompatibleDependencies Nothing ->
|
||||
Help.report
|
||||
"NO COMPATIBLE DEPENDENCIES"
|
||||
Nothing
|
||||
"I failed to find versions of the core packages which are compatible with your current\
|
||||
\ Gren compiler. "
|
||||
[ D.reflow "Maybe you need to update the compiler?"
|
||||
]
|
||||
InitNoCompatibleDependencies (Just gitError) ->
|
||||
toGitErrorReport
|
||||
"FAILED TO LOAD DEPENDENCIES"
|
||||
gitError
|
||||
"I tried to find the latest compatible versions of some core packages, but failed\
|
||||
\ due to a problem with Git. I use Git to download external dependencies from Github."
|
||||
|
||||
-- DIFF
|
||||
|
||||
@ -683,7 +696,9 @@ publishToReport publish =
|
||||
toBuildProblemReport buildProblem
|
||||
PublishCannotGetDocs old new docsProblem ->
|
||||
toDocsProblemReport docsProblem $
|
||||
"I need the docs for " ++ V.toChars old ++ " to verify that "
|
||||
"I need the docs for "
|
||||
++ V.toChars old
|
||||
++ " to verify that "
|
||||
++ V.toChars new
|
||||
++ " really does come next"
|
||||
PublishMissingTag version ->
|
||||
@ -861,6 +876,7 @@ data Install
|
||||
| InstallNoOnlinePkgSolution Pkg.Name
|
||||
| InstallNoOfflinePkgSolution Pkg.Name
|
||||
| InstallHadSolverTrouble Solver
|
||||
| InstallNoCompatiblePkg Pkg.Name
|
||||
| InstallUnknownPackageOnline Pkg.Name [Pkg.Name]
|
||||
| InstallUnknownPackageOffline Pkg.Name [Pkg.Name]
|
||||
| InstallBadDetails Details
|
||||
@ -982,7 +998,8 @@ installToReport exit =
|
||||
Help.report
|
||||
"CANNOT FIND COMPATIBLE VERSION"
|
||||
(Just "gren.json")
|
||||
( "I cannot find a version of " ++ Pkg.toChars pkg
|
||||
( "I cannot find a version of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " that is compatible\
|
||||
\ with your existing dependencies."
|
||||
)
|
||||
@ -1008,7 +1025,8 @@ installToReport exit =
|
||||
Help.report
|
||||
"CANNOT FIND COMPATIBLE VERSION LOCALLY"
|
||||
(Just "gren.json")
|
||||
( "I cannot find a version of " ++ Pkg.toChars pkg
|
||||
( "I cannot find a version of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " that is compatible\
|
||||
\ with your existing dependencies."
|
||||
)
|
||||
@ -1022,7 +1040,8 @@ installToReport exit =
|
||||
Help.report
|
||||
"CANNOT FIND COMPATIBLE VERSION"
|
||||
(Just "gren.json")
|
||||
( "I cannot find a version of " ++ Pkg.toChars pkg
|
||||
( "I cannot find a version of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " that is compatible\
|
||||
\ with your existing constraints."
|
||||
)
|
||||
@ -1042,7 +1061,8 @@ installToReport exit =
|
||||
Help.report
|
||||
"CANNOT FIND COMPATIBLE VERSION LOCALLY"
|
||||
(Just "gren.json")
|
||||
( "I cannot find a version of " ++ Pkg.toChars pkg
|
||||
( "I cannot find a version of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " that is compatible\
|
||||
\ with your existing constraints."
|
||||
)
|
||||
@ -1054,6 +1074,18 @@ installToReport exit =
|
||||
]
|
||||
InstallHadSolverTrouble solver ->
|
||||
toSolverReport solver
|
||||
InstallNoCompatiblePkg pkg ->
|
||||
Help.report
|
||||
"CANNOT FIND COMPATIBLE VERSION"
|
||||
(Just "gren.json")
|
||||
( "I cannot find a version of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " that is compatible with your current Gren compiler."
|
||||
)
|
||||
[ D.reflow $
|
||||
"You'll have to wait for the package to release a version with support for your\
|
||||
\ current Gren compiler, or upgrade."
|
||||
]
|
||||
InstallUnknownPackageOnline pkg suggestions ->
|
||||
Help.docReport
|
||||
"UNKNOWN PACKAGE"
|
||||
@ -1099,7 +1131,10 @@ toSolverReport problem =
|
||||
Help.report
|
||||
"PROBLEM SOLVING PACKAGE CONSTRAINTS"
|
||||
Nothing
|
||||
( "I need the gren.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
|
||||
( "I need the gren.json of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " "
|
||||
++ V.toChars vsn
|
||||
++ " to\
|
||||
\ help me search for a set of compatible packages. I had it cached locally, but\
|
||||
\ it looks like the file was corrupted!"
|
||||
@ -1111,11 +1146,15 @@ toSolverReport problem =
|
||||
]
|
||||
SolverBadGitOperationUnversionedPkg pkg gitError ->
|
||||
toGitErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" gitError $
|
||||
"I need the gren.json of " ++ Pkg.toChars pkg
|
||||
"I need the gren.json of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " to help me search for a set of compatible packages"
|
||||
SolverBadGitOperationVersionedPkg pkg vsn gitError ->
|
||||
toGitErrorReport "PROBLEM SOLVING PACKAGE CONSTRAINTS" gitError $
|
||||
"I need the gren.json of " ++ Pkg.toChars pkg ++ " " ++ V.toChars vsn
|
||||
"I need the gren.json of "
|
||||
++ Pkg.toChars pkg
|
||||
++ " "
|
||||
++ V.toChars vsn
|
||||
++ " to help me search for a set of compatible packages"
|
||||
|
||||
-- OUTLINE
|
||||
@ -1126,7 +1165,6 @@ data Outline
|
||||
| OutlineHasDuplicateSrcDirs FilePath FilePath FilePath
|
||||
| OutlineNoPkgCore
|
||||
| OutlineNoAppCore
|
||||
| OutlineNoAppJson
|
||||
|
||||
data OutlineProblem
|
||||
= OP_BadType
|
||||
@ -1139,6 +1177,7 @@ data OutlineProblem
|
||||
| OP_BadLicense Json.String [Json.String]
|
||||
| OP_BadSummaryTooLong
|
||||
| OP_NoSrcDirs
|
||||
| OP_BadPlatform
|
||||
|
||||
toOutlineReport :: Outline -> Help.Report
|
||||
toOutlineReport problem =
|
||||
@ -1217,17 +1256,6 @@ toOutlineReport problem =
|
||||
\ having trouble getting back to a working gren.json, it may be easier to delete it\
|
||||
\ and use `gren init` to start fresh."
|
||||
]
|
||||
OutlineNoAppJson ->
|
||||
Help.report
|
||||
"MISSING DEPENDENCY"
|
||||
(Just "gren.json")
|
||||
"I need to see an \"gren/json\" dependency your gren.json file. It helps me handle\
|
||||
\ flags and ports."
|
||||
[ D.reflow $
|
||||
"If you modified your gren.json by hand, try to change it back! And if you are\
|
||||
\ having trouble getting back to a working gren.json, it may be easier to delete it\
|
||||
\ and use `gren init` to start fresh."
|
||||
]
|
||||
|
||||
toOutlineProblemReport :: FilePath -> Code.Source -> Json.Context -> A.Region -> OutlineProblem -> Help.Report
|
||||
toOutlineProblemReport path source _ region problem =
|
||||
@ -1660,6 +1688,26 @@ toOutlineProblemReport path source _ region problem =
|
||||
"modules!"
|
||||
]
|
||||
)
|
||||
OP_BadPlatform ->
|
||||
toSnippet
|
||||
"UNKNOWN PLATFORM"
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"I got stuck while reading your gren.json file. I don't recognize the \"platform\" value.",
|
||||
D.fillSep
|
||||
[ "It",
|
||||
"must",
|
||||
"be",
|
||||
"one",
|
||||
"of",
|
||||
D.green "\"common\"",
|
||||
",",
|
||||
D.green "\"browser\"",
|
||||
"or",
|
||||
D.green "\"node\"",
|
||||
"."
|
||||
]
|
||||
)
|
||||
|
||||
-- DETAILS
|
||||
|
||||
@ -1825,7 +1873,8 @@ toDetailsReport details =
|
||||
Nothing
|
||||
"I am not sure what is going wrong though."
|
||||
[ D.reflow $
|
||||
"I would try deleting the " ++ cacheDir
|
||||
"I would try deleting the "
|
||||
++ cacheDir
|
||||
++ " and .gren/ directories, then\
|
||||
\ trying to build again. That will work if some cached files got corrupted\
|
||||
\ somehow.",
|
||||
@ -1865,35 +1914,45 @@ toGitErrorReport :: String -> Git.Error -> String -> Help.Report
|
||||
toGitErrorReport title err context =
|
||||
let toGitReport intro details =
|
||||
Help.report title Nothing intro details
|
||||
|
||||
prettyPrintGitCommand maybePath args =
|
||||
let suffix =
|
||||
case maybePath of
|
||||
Just path -> " in " ++ path
|
||||
Nothing -> ""
|
||||
in unwords args ++ suffix
|
||||
in case err of
|
||||
Git.MissingGit ->
|
||||
toGitReport
|
||||
(context ++ ", I couldn't find a git binary.")
|
||||
(context ++ ", but I couldn't find a git binary.")
|
||||
[ D.reflow
|
||||
"I use git to clone dependencies from github.\
|
||||
\ Make sure that git is installed and present in your PATH."
|
||||
]
|
||||
Git.FailedCommand maybePath args errorMsg ->
|
||||
Git.NoVersions ->
|
||||
toGitReport
|
||||
(context ++ ", so I tried to execute: " ++ prettyPrintGitCommand maybePath args)
|
||||
[ D.reflow "But it returned the following error message:",
|
||||
D.indent 4 $ D.reflow errorMsg
|
||||
]
|
||||
Git.NoVersions _ ->
|
||||
toGitReport
|
||||
(context ++ ", no valid semantic version tags in this repo.")
|
||||
(context ++ ", but I couldn't find any semver compatible tags in this repo.")
|
||||
[ D.reflow
|
||||
"Gren packages are just git repositories with tags following the \
|
||||
\ semantic versioning scheme. However, it seems that this particular repo \
|
||||
\ doesn't have _any_ semantic version tags!"
|
||||
]
|
||||
Git.NoSuchRepo ->
|
||||
toGitReport
|
||||
(context ++ ", but I couldn't find the repo on github.")
|
||||
[ D.reflow
|
||||
"Gren packages are just git repositories hosted on github, however \
|
||||
\ it seems like this repo doesn't exist."
|
||||
]
|
||||
Git.NoSuchRepoOrVersion vsn ->
|
||||
toGitReport
|
||||
(context ++ ", but I couldn't find the correct version of this package on github.")
|
||||
[ D.reflow $
|
||||
"Gren packages are just git repositories hosted on github with semver \
|
||||
\ formatted tags. However, it seems like this package, or version "
|
||||
++ V.toChars vsn
|
||||
++ ", doesn't exist."
|
||||
]
|
||||
Git.FailedCommand args errorMsg ->
|
||||
toGitReport
|
||||
(context ++ ", so I tried to execute:")
|
||||
[ D.indent 4 $ D.reflow $ unwords args,
|
||||
D.reflow "But it returned the following error message:",
|
||||
D.indent 4 $ D.reflow errorMsg
|
||||
]
|
||||
|
||||
-- MAKE
|
||||
|
||||
@ -2230,7 +2289,8 @@ toProjectProblemReport projectProblem =
|
||||
"These two files are causing a module name clash:"
|
||||
[ D.indent 4 $ D.red $ D.vcat $ map D.fromChars [outsidePath, otherPath],
|
||||
D.reflow $
|
||||
"They both say `module " ++ ModuleName.toChars name
|
||||
"They both say `module "
|
||||
++ ModuleName.toChars name
|
||||
++ " exposing (..)` up\
|
||||
\ at the top, but they cannot have the same name!",
|
||||
D.reflow $
|
||||
@ -2243,7 +2303,8 @@ toProjectProblemReport projectProblem =
|
||||
"I am having trouble with this file name:"
|
||||
[ D.indent 4 $ D.red $ D.fromChars givenPath,
|
||||
D.reflow $
|
||||
"I found it in your " ++ FP.addTrailingPathSeparator srcDir
|
||||
"I found it in your "
|
||||
++ FP.addTrailingPathSeparator srcDir
|
||||
++ " directory\
|
||||
\ which is good, but I expect all of the files in there to use the following\
|
||||
\ module naming convention:",
|
||||
@ -2286,7 +2347,8 @@ toProjectProblemReport projectProblem =
|
||||
"The \"exposed-modules\" of your gren.json lists the following module:"
|
||||
[ D.indent 4 $ D.red $ D.fromName name,
|
||||
D.reflow $
|
||||
"But a module from " ++ Pkg.toChars pkg
|
||||
"But a module from "
|
||||
++ Pkg.toChars pkg
|
||||
++ " already uses that name. Try\
|
||||
\ choosing a different name for your local file."
|
||||
]
|
||||
@ -2396,32 +2458,6 @@ corruptCacheReport =
|
||||
\ one by one until you figure out which it is!"
|
||||
]
|
||||
|
||||
-- REACTOR
|
||||
|
||||
data Reactor
|
||||
= ReactorNoOutline
|
||||
| ReactorBadDetails Details
|
||||
| ReactorBadBuild BuildProblem
|
||||
| ReactorBadGenerate Generate
|
||||
|
||||
reactorToReport :: Reactor -> Help.Report
|
||||
reactorToReport problem =
|
||||
case problem of
|
||||
ReactorNoOutline ->
|
||||
Help.report
|
||||
"NEW PROJECT?"
|
||||
Nothing
|
||||
"Are you trying to start a new project? Try this command in the terminal:"
|
||||
[ D.indent 4 $ D.green "gren init",
|
||||
D.reflow "It will help you get started!"
|
||||
]
|
||||
ReactorBadDetails details ->
|
||||
toDetailsReport details
|
||||
ReactorBadBuild buildProblem ->
|
||||
toBuildProblemReport buildProblem
|
||||
ReactorBadGenerate generate ->
|
||||
toGenerateReport generate
|
||||
|
||||
-- REPL
|
||||
|
||||
data Repl
|
||||
|
@ -16,10 +16,10 @@ where
|
||||
|
||||
import GHC.IO.Handle (hIsTerminalDevice)
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import Json.Encode qualified as E
|
||||
import Reporting.Doc ((<+>))
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Error as Error
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Error qualified as Error
|
||||
import System.IO (Handle, hPutStr, stderr, stdout)
|
||||
|
||||
-- REPORT
|
||||
|
@ -55,18 +55,18 @@ cached data with comments like:
|
||||
So it is clear why the data is kept around.
|
||||
-}
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import AST.Source qualified as Src
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
|
||||
import Data.Binary
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name (Name)
|
||||
import qualified Gren.Float as EF
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.String as ES
|
||||
import qualified Reporting.Annotation as A
|
||||
import Gren.Float qualified as EF
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.String qualified as ES
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- EXPRESSIONS
|
||||
|
||||
@ -98,20 +98,24 @@ data Expr_
|
||||
| Case Expr [CaseBranch]
|
||||
| Accessor Name
|
||||
| Access Expr (A.Located Name)
|
||||
| Update Name Expr (Map.Map Name FieldUpdate)
|
||||
| Update Expr (Map.Map Name FieldUpdate)
|
||||
| Record (Map.Map Name Expr)
|
||||
deriving (Show)
|
||||
|
||||
data CaseBranch
|
||||
= CaseBranch Pattern Expr
|
||||
deriving (Show)
|
||||
|
||||
data FieldUpdate
|
||||
= FieldUpdate A.Region Expr
|
||||
deriving (Show)
|
||||
|
||||
-- DEFS
|
||||
|
||||
data Def
|
||||
= Def (A.Located Name) [Pattern] Expr
|
||||
| TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
|
||||
deriving (Show)
|
||||
|
||||
-- DECLARATIONS
|
||||
|
||||
@ -119,6 +123,7 @@ data Decls
|
||||
= Declare Def Decls
|
||||
| DeclareRec Def [Def] Decls
|
||||
| SaveTheEnvironment
|
||||
deriving (Show)
|
||||
|
||||
-- PATTERNS
|
||||
|
||||
@ -143,10 +148,12 @@ data Pattern_
|
||||
_p_index :: Index.ZeroBased,
|
||||
_p_args :: [PatternCtorArg]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type PatternRecordField = A.Located PatternRecordField_
|
||||
|
||||
data PatternRecordField_ = PRFieldPattern Name Pattern
|
||||
deriving (Show)
|
||||
|
||||
-- CACHE _p_home, _p_type, and _p_vars for type inference
|
||||
-- CACHE _p_index to replace _p_name in PROD code gen
|
||||
@ -158,11 +165,12 @@ data PatternCtorArg = PatternCtorArg
|
||||
_type :: Type, -- CACHE for type inference
|
||||
_arg :: Pattern
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- TYPES
|
||||
|
||||
data Annotation = Forall FreeVars Type
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
type FreeVars = Map.Map Name ()
|
||||
|
||||
@ -172,15 +180,15 @@ data Type
|
||||
| TType ModuleName.Canonical Name [Type]
|
||||
| TRecord (Map.Map Name FieldType) (Maybe Name)
|
||||
| TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data AliasType
|
||||
= Holey Type
|
||||
| Filled Type
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FieldType = FieldType {-# UNPACK #-} !Word16 Type
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- NOTE: The Word16 marks the source order, but it may not be available
|
||||
-- for every canonical type. For example, if the canonical type is inferred
|
||||
@ -190,7 +198,6 @@ fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]
|
||||
fieldsToList fields =
|
||||
let getIndex (_, FieldType index _) =
|
||||
index
|
||||
|
||||
dropIndex (name, FieldType _ tipe) =
|
||||
(name, tipe)
|
||||
in map dropIndex (List.sortOn getIndex (Map.toList fields))
|
||||
@ -207,12 +214,13 @@ data Module = Module
|
||||
_binops :: Map.Map Name Binop,
|
||||
_effects :: Effects
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Alias = Alias [Name] Type
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Binop = Binop_ Binop.Associativity Binop.Precedence Name
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Union = Union
|
||||
{ _u_vars :: [Name],
|
||||
@ -220,22 +228,23 @@ data Union = Union
|
||||
_u_numAlts :: Int, -- CACHE numAlts for exhaustiveness checking
|
||||
_u_opts :: CtorOpts -- CACHE which optimizations are available
|
||||
}
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data CtorOpts
|
||||
= Normal
|
||||
| Enum
|
||||
| Unbox
|
||||
deriving (Eq, Ord)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- EXPORTS
|
||||
|
||||
data Exports
|
||||
= ExportEverything A.Region
|
||||
| Export (Map.Map Name (A.Located Export))
|
||||
deriving (Show)
|
||||
|
||||
data Export
|
||||
= ExportValue
|
||||
@ -244,6 +253,7 @@ data Export
|
||||
| ExportUnionOpen
|
||||
| ExportUnionClosed
|
||||
| ExportPort
|
||||
deriving (Show)
|
||||
|
||||
-- EFFECTS
|
||||
|
||||
@ -251,15 +261,18 @@ data Effects
|
||||
= NoEffects
|
||||
| Ports (Map.Map Name Port)
|
||||
| Manager A.Region A.Region A.Region Manager
|
||||
deriving (Show)
|
||||
|
||||
data Port
|
||||
= Incoming {_freeVars :: FreeVars, _payload :: Type, _func :: Type}
|
||||
| Outgoing {_freeVars :: FreeVars, _payload :: Type, _func :: Type}
|
||||
deriving (Show)
|
||||
|
||||
data Manager
|
||||
= Cmd Name
|
||||
| Sub Name
|
||||
| Fx Name Name
|
||||
deriving (Show)
|
||||
|
||||
-- BINARY
|
||||
|
||||
|
@ -21,21 +21,21 @@ module AST.Optimized
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import AST.Canonical qualified as Can
|
||||
import Control.Monad (liftM, liftM2, liftM3, liftM4)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map as Map
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name (Name)
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.Float as EF
|
||||
import qualified Gren.Kernel as K
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.String as ES
|
||||
import qualified Optimize.DecisionTree as DT
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.Float qualified as EF
|
||||
import Gren.Kernel qualified as K
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.String qualified as ES
|
||||
import Optimize.DecisionTree qualified as DT
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- EXPRESSIONS
|
||||
|
||||
|
@ -34,20 +34,21 @@ module AST.Source
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Name (Name)
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import qualified Gren.Float as EF
|
||||
import qualified Gren.String as ES
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Gren.Float qualified as EF
|
||||
import Gren.String qualified as ES
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- COMMENTS
|
||||
|
||||
data Comment
|
||||
= BlockComment (Utf8.Utf8 GREN_COMMENT)
|
||||
| LineComment (Utf8.Utf8 GREN_COMMENT)
|
||||
deriving (Show)
|
||||
|
||||
data GREN_COMMENT
|
||||
|
||||
@ -73,16 +74,19 @@ data Expr_
|
||||
| Case Expr [(Pattern, Expr)]
|
||||
| Accessor Name
|
||||
| Access Expr (A.Located Name)
|
||||
| Update (A.Located Name) [(A.Located Name, Expr)]
|
||||
| Update Expr [(A.Located Name, Expr)]
|
||||
| Record [(A.Located Name, Expr)]
|
||||
deriving (Show)
|
||||
|
||||
data VarType = LowVar | CapVar
|
||||
deriving (Show)
|
||||
|
||||
-- DEFINITIONS
|
||||
|
||||
data Def
|
||||
= Define (A.Located Name) [Pattern] Expr (Maybe Type)
|
||||
| Destruct Pattern Expr
|
||||
deriving (Show)
|
||||
|
||||
-- PATTERN
|
||||
|
||||
@ -99,10 +103,12 @@ data Pattern_
|
||||
| PChr ES.String
|
||||
| PStr ES.String
|
||||
| PInt Int
|
||||
deriving (Show)
|
||||
|
||||
type RecordFieldPattern = A.Located RecordFieldPattern_
|
||||
|
||||
data RecordFieldPattern_ = RFPattern (A.Located Name) Pattern
|
||||
deriving (Show)
|
||||
|
||||
-- TYPE
|
||||
|
||||
@ -115,6 +121,7 @@ data Type_
|
||||
| TType A.Region Name [Type]
|
||||
| TTypeQual A.Region Name Name [Type]
|
||||
| TRecord [(A.Located Name, Type)] (Maybe (A.Located Name))
|
||||
deriving (Show)
|
||||
|
||||
-- MODULE
|
||||
|
||||
@ -131,6 +138,7 @@ data Module = Module
|
||||
_binops :: [A.Located Infix],
|
||||
_effects :: Effects
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
getName :: Module -> Name
|
||||
getName (Module maybeName _ _ _ _ _ _ _ _) =
|
||||
@ -149,45 +157,58 @@ data Import = Import
|
||||
_alias :: Maybe Name,
|
||||
_exposing :: Exposing
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Value = Value (A.Located Name) [Pattern] Expr (Maybe Type)
|
||||
deriving (Show)
|
||||
|
||||
data Union = Union (A.Located Name) [A.Located Name] [(A.Located Name, [Type])]
|
||||
deriving (Show)
|
||||
|
||||
data Alias = Alias (A.Located Name) [A.Located Name] Type
|
||||
deriving (Show)
|
||||
|
||||
data Infix = Infix Name Binop.Associativity Binop.Precedence Name
|
||||
deriving (Show)
|
||||
|
||||
data Port = Port (A.Located Name) Type
|
||||
deriving (Show)
|
||||
|
||||
data Effects
|
||||
= NoEffects
|
||||
| Ports [(SourceOrder, Port)]
|
||||
| Manager A.Region Manager
|
||||
deriving (Show)
|
||||
|
||||
data Manager
|
||||
= Cmd (A.Located Name)
|
||||
| Sub (A.Located Name)
|
||||
| Fx (A.Located Name) (A.Located Name)
|
||||
deriving (Show)
|
||||
|
||||
data Docs
|
||||
= NoDocs A.Region
|
||||
| YesDocs DocComment [(Name, DocComment)]
|
||||
deriving (Show)
|
||||
|
||||
newtype DocComment
|
||||
= DocComment P.Snippet
|
||||
deriving (Show)
|
||||
|
||||
-- EXPOSING
|
||||
|
||||
data Exposing
|
||||
= Open
|
||||
| Explicit [Exposed]
|
||||
deriving (Show)
|
||||
|
||||
data Exposed
|
||||
= Lower (A.Located Name)
|
||||
| Upper (A.Located Name) Privacy
|
||||
| Operator A.Region Name
|
||||
deriving (Show)
|
||||
|
||||
data Privacy
|
||||
= Public A.Region
|
||||
| Private
|
||||
deriving (Show)
|
||||
|
@ -13,13 +13,13 @@ import Prelude hiding (Either (..))
|
||||
-- BINOP STUFF
|
||||
|
||||
newtype Precedence = Precedence Int
|
||||
deriving (Eq, Ord)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Associativity
|
||||
= Left
|
||||
| Non
|
||||
| Right
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- BINARY
|
||||
|
||||
|
@ -9,8 +9,8 @@ module AST.Utils.Type
|
||||
where
|
||||
|
||||
import AST.Canonical (AliasType (..), FieldType (..), Type (..))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
|
||||
-- DELAMBDA
|
||||
|
||||
|
@ -7,18 +7,18 @@ module Canonicalize.Effects
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified AST.Utils.Type as Type
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Type as Type
|
||||
import qualified Data.Foldable as F
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import AST.Utils.Type qualified as Type
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Type qualified as Type
|
||||
import Data.Foldable qualified as F
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -20,17 +20,17 @@ module Canonicalize.Environment
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map.Merge.Strict as Map
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map.Merge.Strict qualified as Map
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -14,12 +14,12 @@ module Canonicalize.Environment.Dups
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- DUPLICATE TRACKER
|
||||
|
||||
|
@ -7,20 +7,20 @@ module Canonicalize.Environment.Foreign
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.List as List
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict ((!))
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -6,21 +6,21 @@ module Canonicalize.Environment.Local
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Environment.Dups as Dups
|
||||
import qualified Canonicalize.Type as Type
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Environment.Dups qualified as Dups
|
||||
import Canonicalize.Type qualified as Type
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.Graph as Graph
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import Data.Graph qualified as Graph
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -10,26 +10,26 @@ module Canonicalize.Expression
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import qualified AST.Utils.Type as Type
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Environment.Dups as Dups
|
||||
import qualified Canonicalize.Pattern as Pattern
|
||||
import qualified Canonicalize.Type as Type
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import AST.Utils.Type qualified as Type
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Environment.Dups qualified as Dups
|
||||
import Canonicalize.Pattern qualified as Pattern
|
||||
import Canonicalize.Type qualified as Type
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.Graph as Graph
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import qualified Reporting.Warning as W
|
||||
import Data.Graph qualified as Graph
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
import Reporting.Warning qualified as W
|
||||
|
||||
-- RESULTS
|
||||
|
||||
@ -110,11 +110,11 @@ canonicalize env (A.At region expression) =
|
||||
Can.Access
|
||||
<$> canonicalize env record
|
||||
<*> Result.ok field
|
||||
Src.Update (A.At reg name) fields ->
|
||||
Src.Update baseRecord fields ->
|
||||
let makeCanFields =
|
||||
Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields
|
||||
in Can.Update name
|
||||
<$> (A.At reg <$> findVar reg env name)
|
||||
in Can.Update
|
||||
<$> (canonicalize env baseRecord)
|
||||
<*> (sequenceA =<< makeCanFields)
|
||||
Src.Record fields ->
|
||||
do
|
||||
|
@ -5,27 +5,27 @@ module Canonicalize.Module
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Effects as Effects
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Environment.Dups as Dups
|
||||
import qualified Canonicalize.Environment.Foreign as Foreign
|
||||
import qualified Canonicalize.Environment.Local as Local
|
||||
import qualified Canonicalize.Expression as Expr
|
||||
import qualified Canonicalize.Pattern as Pattern
|
||||
import qualified Canonicalize.Type as Type
|
||||
import qualified Data.Graph as Graph
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import qualified Reporting.Warning as W
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Effects qualified as Effects
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Environment.Dups qualified as Dups
|
||||
import Canonicalize.Environment.Foreign qualified as Foreign
|
||||
import Canonicalize.Environment.Local qualified as Local
|
||||
import Canonicalize.Expression qualified as Expr
|
||||
import Canonicalize.Pattern qualified as Pattern
|
||||
import Canonicalize.Type qualified as Type
|
||||
import Data.Graph qualified as Graph
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
import Reporting.Warning qualified as W
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -8,17 +8,17 @@ module Canonicalize.Pattern
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Environment.Dups as Dups
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Environment.Dups qualified as Dups
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULTS
|
||||
|
||||
|
@ -7,16 +7,16 @@ module Canonicalize.Type
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Environment as Env
|
||||
import qualified Canonicalize.Environment.Dups as Dups
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Canonicalize as Error
|
||||
import qualified Reporting.Result as Result
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Environment qualified as Env
|
||||
import Canonicalize.Environment.Dups qualified as Dups
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Canonicalize qualified as Error
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- RESULT
|
||||
|
||||
|
@ -4,23 +4,23 @@ module Compile
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Source as Src
|
||||
import qualified Canonicalize.Module as Canonicalize
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Nitpick.PatternMatches as PatternMatches
|
||||
import qualified Optimize.Module as Optimize
|
||||
import qualified Reporting.Error as E
|
||||
import qualified Reporting.Render.Type.Localizer as Localizer
|
||||
import qualified Reporting.Result as R
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Source qualified as Src
|
||||
import Canonicalize.Module qualified as Canonicalize
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Nitpick.PatternMatches qualified as PatternMatches
|
||||
import Optimize.Module qualified as Optimize
|
||||
import Reporting.Error qualified as E
|
||||
import Reporting.Render.Type.Localizer qualified as Localizer
|
||||
import Reporting.Result qualified as R
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified Type.Constrain.Module as Type
|
||||
import qualified Type.Solve as Type
|
||||
import Type.Constrain.Module qualified as Type
|
||||
import Type.Solve qualified as Type
|
||||
|
||||
-- COMPILE
|
||||
|
||||
|
@ -11,7 +11,7 @@ module Data.Bag
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.List as List
|
||||
import Data.List qualified as List
|
||||
import Prelude hiding (map)
|
||||
|
||||
-- BAGS
|
||||
|
@ -21,7 +21,7 @@ import Data.Binary
|
||||
-- ZERO BASED
|
||||
|
||||
newtype ZeroBased = ZeroBased Int
|
||||
deriving (Eq, Ord)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
first :: ZeroBased
|
||||
first =
|
||||
|
@ -6,7 +6,7 @@ module Data.Map.Utils
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map qualified as Map
|
||||
import Data.Map.Internal (Map (..))
|
||||
import Prelude hiding (any)
|
||||
|
||||
|
@ -67,12 +67,12 @@ module Data.Name
|
||||
where
|
||||
|
||||
import Control.Exception (assert)
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Builder.Internal as B
|
||||
import qualified Data.Coerce as Coerce
|
||||
import qualified Data.List as List
|
||||
import qualified Data.String as Chars
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Binary qualified as Binary
|
||||
import Data.ByteString.Builder.Internal qualified as B
|
||||
import Data.Coerce qualified as Coerce
|
||||
import Data.List qualified as List
|
||||
import Data.String qualified as Chars
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import GHC.Exts
|
||||
( Int (I#),
|
||||
Ptr,
|
||||
@ -81,7 +81,7 @@ import GHC.Exts
|
||||
import GHC.Prim
|
||||
import GHC.ST (ST (ST), runST)
|
||||
import GHC.Word (Word8 (W8#))
|
||||
import qualified Gren.String as ES
|
||||
import Gren.String qualified as ES
|
||||
import Prelude hiding (length, maybe, negate)
|
||||
|
||||
-- NAME
|
||||
|
@ -8,7 +8,7 @@ where
|
||||
|
||||
import Control.Monad (liftM2)
|
||||
import Data.Binary (Binary, get, put)
|
||||
import qualified Data.List as List
|
||||
import Data.List qualified as List
|
||||
|
||||
-- LIST
|
||||
|
||||
|
@ -42,10 +42,10 @@ import Data.Binary (Get, Put, get, getWord8, put, putWord8)
|
||||
import Data.Binary.Get.Internal (readN)
|
||||
import Data.Binary.Put (putBuilder)
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import qualified Data.ByteString.Builder.Internal as B
|
||||
import qualified Data.ByteString.Internal as B
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.List as List
|
||||
import Data.ByteString.Builder.Internal qualified as B
|
||||
import Data.ByteString.Internal qualified as B
|
||||
import Data.Char qualified as Char
|
||||
import Data.List qualified as List
|
||||
import Foreign.ForeignPtr (touchForeignPtr)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (minusPtr, plusPtr)
|
||||
@ -59,7 +59,7 @@ import GHC.IO
|
||||
import GHC.Prim
|
||||
import GHC.ST (ST (ST), runST)
|
||||
import GHC.Word (Word8 (W8#))
|
||||
import qualified Parse.Primitives as P
|
||||
import Parse.Primitives qualified as P
|
||||
import Prelude hiding (String, all, any, concat)
|
||||
|
||||
-- UTF-8
|
||||
@ -67,6 +67,9 @@ import Prelude hiding (String, all, any, concat)
|
||||
data Utf8 tipe
|
||||
= Utf8 ByteArray#
|
||||
|
||||
instance Show (Utf8 tipe) where
|
||||
show str = '"' : toChars str ++ "\""
|
||||
|
||||
-- EMPTY
|
||||
|
||||
empty :: Utf8 t
|
||||
|
@ -6,8 +6,8 @@ module Generate.Html
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.Name as Name
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Name qualified as Name
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
-- SANDWICH
|
||||
|
@ -7,26 +7,26 @@ module Generate.JavaScript
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import qualified Generate.JavaScript.Builder as JS
|
||||
import qualified Generate.JavaScript.Expression as Expr
|
||||
import qualified Generate.JavaScript.Functions as Functions
|
||||
import qualified Generate.JavaScript.Name as JsName
|
||||
import qualified Generate.Mode as Mode
|
||||
import qualified Gren.Kernel as K
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Type as RT
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Generate.JavaScript.Builder qualified as JS
|
||||
import Generate.JavaScript.Expression qualified as Expr
|
||||
import Generate.JavaScript.Functions qualified as Functions
|
||||
import Generate.JavaScript.Name qualified as JsName
|
||||
import Generate.Mode qualified as Mode
|
||||
import Gren.Kernel qualified as K
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Type qualified as RT
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
import Prelude hiding (cycle, print)
|
||||
|
||||
-- GENERATE
|
||||
@ -81,7 +81,12 @@ print ansi localizer home name tipe =
|
||||
toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
|
||||
tipeDoc = RT.canToDoc localizer RT.None tipe
|
||||
bool = if ansi then "true" else "false"
|
||||
in "var _value = " <> toString <> "(" <> bool <> ", " <> value
|
||||
in "var _value = "
|
||||
<> toString
|
||||
<> "("
|
||||
<> bool
|
||||
<> ", "
|
||||
<> value
|
||||
<> ");\n\
|
||||
\var _type = "
|
||||
<> B.stringUtf8 (show (D.toString tipeDoc))
|
||||
@ -251,7 +256,9 @@ generateCycle mode (Opt.Global home _) names values functions =
|
||||
JS.Try (JS.Block realBlock) JsName.dollar $
|
||||
JS.Throw $
|
||||
JS.String $
|
||||
"Some top-level definitions from `" <> Name.toBuilder (ModuleName._module home) <> "` are causing infinite recursion:\\n"
|
||||
"Some top-level definitions from `"
|
||||
<> Name.toBuilder (ModuleName._module home)
|
||||
<> "` are causing infinite recursion:\\n"
|
||||
<> drawCycle names
|
||||
<> "\\n\\nThese errors are very tricky, so read "
|
||||
<> B.stringUtf8 (D.makeNakedLink "bad-recursion")
|
||||
|
@ -18,12 +18,12 @@ where
|
||||
-- They did the hard work of reading the spec to figure out
|
||||
-- how all the types should fit together.
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Builder as B
|
||||
import qualified Data.List as List
|
||||
import Data.List qualified as List
|
||||
import Generate.JavaScript.Name (Name)
|
||||
import qualified Generate.JavaScript.Name as Name
|
||||
import qualified Json.Encode as Json
|
||||
import Generate.JavaScript.Name qualified as Name
|
||||
import Json.Encode qualified as Json
|
||||
import Prelude hiding (lines)
|
||||
|
||||
-- EXPRESSIONS
|
||||
@ -240,7 +240,12 @@ fromStmt level@(Level indent nextLevel) statement =
|
||||
Vars vars ->
|
||||
indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
|
||||
FunctionStmt name args stmts ->
|
||||
indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
|
||||
indent
|
||||
<> "function "
|
||||
<> Name.toBuilder name
|
||||
<> "("
|
||||
<> commaSep (map Name.toBuilder args)
|
||||
<> ") {\n"
|
||||
<> fromStmtBlock nextLevel stmts
|
||||
<> indent
|
||||
<> "}\n"
|
||||
@ -251,10 +256,14 @@ fromClause :: Level -> Case -> Builder
|
||||
fromClause level@(Level indent nextLevel) clause =
|
||||
case clause of
|
||||
Case expr stmts ->
|
||||
indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
|
||||
indent
|
||||
<> "case "
|
||||
<> snd (fromExpr level Whatever expr)
|
||||
<> ":\n"
|
||||
<> fromStmtBlock nextLevel stmts
|
||||
Default stmts ->
|
||||
indent <> "default:\n"
|
||||
indent
|
||||
<> "default:\n"
|
||||
<> fromStmtBlock nextLevel stmts
|
||||
|
||||
-- VAR DECLS
|
||||
@ -366,7 +375,11 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi
|
||||
else funcB <> "(" <> commaSep argsB <> ")"
|
||||
Function maybeName args stmts ->
|
||||
(,) Many $
|
||||
"function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
|
||||
"function "
|
||||
<> maybe mempty Name.toBuilder maybeName
|
||||
<> "("
|
||||
<> commaSep (map Name.toBuilder args)
|
||||
<> ") {\n"
|
||||
<> fromStmtBlock nextLevel stmts
|
||||
<> indent
|
||||
<> "}"
|
||||
|
@ -12,27 +12,27 @@ module Generate.JavaScript.Expression
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.List as List
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import Data.Index qualified as Index
|
||||
import Data.IntMap qualified as IntMap
|
||||
import Data.List qualified as List
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import qualified Generate.JavaScript.Builder as JS
|
||||
import qualified Generate.JavaScript.Name as JsName
|
||||
import qualified Generate.Mode as Mode
|
||||
import qualified Gren.Compiler.Type as Type
|
||||
import qualified Gren.Compiler.Type.Extract as Extract
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Generate.JavaScript.Builder qualified as JS
|
||||
import Generate.JavaScript.Name qualified as JsName
|
||||
import Generate.Mode qualified as Mode
|
||||
import Gren.Compiler.Type qualified as Type
|
||||
import Gren.Compiler.Type.Extract qualified as Extract
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as Encode
|
||||
import qualified Optimize.DecisionTree as DT
|
||||
import qualified Reporting.Annotation as A
|
||||
import Json.Encode qualified as Encode
|
||||
import Optimize.DecisionTree qualified as DT
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- EXPRESSIONS
|
||||
|
||||
@ -492,8 +492,8 @@ generateTailCall mode name args =
|
||||
toRealVars (argName, _) =
|
||||
JS.ExprStmt $
|
||||
JS.Assign (JS.LRef (JsName.fromLocal argName)) (JS.Ref (JsName.makeTemp argName))
|
||||
in JS.Vars (map toTempVars args) :
|
||||
map toRealVars args
|
||||
in JS.Vars (map toTempVars args)
|
||||
: map toRealVars args
|
||||
++ [JS.Continue (Just (JsName.fromLocal name))]
|
||||
|
||||
-- DEFINITIONS
|
||||
@ -512,7 +512,8 @@ generateTailDef mode name argNames body =
|
||||
JsBlock $
|
||||
[ JS.Labelled (JsName.fromLocal name) $
|
||||
JS.While (JS.Bool True) $
|
||||
codeToStmt $ generate mode body
|
||||
codeToStmt $
|
||||
generate mode body
|
||||
]
|
||||
|
||||
-- PATHS
|
||||
|
@ -6,7 +6,7 @@ module Generate.JavaScript.Functions
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
-- FUNCTIONS
|
||||
|
@ -18,15 +18,15 @@ module Generate.JavaScript.Name
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word8)
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
|
||||
-- NAME
|
||||
|
||||
|
@ -6,13 +6,13 @@ module Generate.Mode
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Generate.JavaScript.Name as JsName
|
||||
import qualified Gren.Compiler.Type.Extract as Extract
|
||||
import AST.Optimized qualified as Opt
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Generate.JavaScript.Name qualified as JsName
|
||||
import Gren.Compiler.Type.Extract qualified as Extract
|
||||
|
||||
-- MODE
|
||||
|
||||
|
@ -6,10 +6,10 @@ module Gren.Compiler.Imports
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- DEFAULTS
|
||||
|
||||
|
@ -14,18 +14,18 @@ module Gren.Compiler.Type
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import qualified Json.Decode as D
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Type as Type
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Type as RT
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Type qualified as Type
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Type qualified as RT
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
|
||||
-- TYPES
|
||||
|
||||
|
@ -15,16 +15,16 @@ module Gren.Compiler.Type.Extract
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Utils.Type as Type
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Utils.Type qualified as Type
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.Compiler.Type as T
|
||||
import qualified Gren.Interface as I
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.Compiler.Type qualified as T
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
|
||||
-- EXTRACTION
|
||||
|
||||
|
@ -4,7 +4,8 @@
|
||||
module Gren.Constraint
|
||||
( Constraint,
|
||||
exactly,
|
||||
anything,
|
||||
lowerBound,
|
||||
upperBound,
|
||||
toChars,
|
||||
satisfies,
|
||||
check,
|
||||
@ -23,11 +24,11 @@ where
|
||||
|
||||
import Control.Monad (liftM4)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as D
|
||||
import qualified Json.Encode as E
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import Parse.Primitives qualified as P
|
||||
|
||||
-- CONSTRAINTS
|
||||
|
||||
@ -46,9 +47,15 @@ exactly :: V.Version -> Constraint
|
||||
exactly version =
|
||||
Range version LessOrEqual LessOrEqual version
|
||||
|
||||
anything :: Constraint
|
||||
anything =
|
||||
Range V.one LessOrEqual LessOrEqual V.max
|
||||
-- EXTRACT VERSION
|
||||
|
||||
lowerBound :: Constraint -> V.Version
|
||||
lowerBound (Range lower _ _ _) =
|
||||
lower
|
||||
|
||||
upperBound :: Constraint -> V.Version
|
||||
upperBound (Range _ _ _ upper) =
|
||||
upper
|
||||
|
||||
-- TO CHARS
|
||||
|
||||
|
@ -22,34 +22,34 @@ module Gren.Docs
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import qualified Data.Coerce as Coerce
|
||||
import qualified Data.List as List
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Coerce qualified as Coerce
|
||||
import Data.List qualified as List
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Map.Merge.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import Data.Map qualified as Map
|
||||
import Data.Map.Merge.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr, plusPtr)
|
||||
import qualified Gren.Compiler.Type as Type
|
||||
import qualified Gren.Compiler.Type.Extract as Extract
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Json.Decode as D
|
||||
import Gren.Compiler.Type qualified as Type
|
||||
import Gren.Compiler.Type.Extract qualified as Extract
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives (Col, Row, word1)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.Symbol as Symbol
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Docs as E
|
||||
import qualified Reporting.Result as Result
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.Symbol qualified as Symbol
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Docs qualified as E
|
||||
import Reporting.Result qualified as Result
|
||||
|
||||
-- DOCUMENTATION
|
||||
|
||||
|
@ -10,8 +10,8 @@ module Gren.Float
|
||||
where
|
||||
|
||||
import Data.Binary (Binary, get, put)
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr)
|
||||
import Prelude hiding (Float)
|
||||
|
@ -17,16 +17,16 @@ module Gren.Interface
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Control.Monad (liftM, liftM3, liftM4, liftM5)
|
||||
import Data.Binary
|
||||
import qualified Data.Map.Merge.Strict as Map
|
||||
import Data.Map.Merge.Strict qualified as Map
|
||||
import Data.Map.Strict ((!))
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Map.Strict qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Package qualified as Pkg
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- INTERFACE
|
||||
|
||||
@ -37,18 +37,18 @@ data Interface = Interface
|
||||
_aliases :: Map.Map Name.Name Alias,
|
||||
_binops :: Map.Map Name.Name Binop
|
||||
}
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Union
|
||||
= OpenUnion Can.Union
|
||||
| ClosedUnion Can.Union
|
||||
| PrivateUnion Can.Union
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Alias
|
||||
= PublicAlias Can.Alias
|
||||
| PrivateAlias Can.Alias
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Binop = Binop
|
||||
{ _op_name :: Name.Name,
|
||||
@ -56,7 +56,7 @@ data Binop = Binop
|
||||
_op_associativity :: Binop.Associativity,
|
||||
_op_precedence :: Binop.Precedence
|
||||
}
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- FROM MODULE
|
||||
|
||||
|
@ -14,25 +14,25 @@ module Gren.Kernel
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import AST.Source qualified as Src
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Data.ByteString.Internal as B
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import Data.ByteString.Internal qualified as B
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Word (Word8)
|
||||
import Foreign.ForeignPtr (ForeignPtr)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Parse.Module as Module
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Parse.Module qualified as Module
|
||||
import Parse.Primitives hiding (fromByteString)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- CHUNK
|
||||
|
||||
|
@ -9,12 +9,12 @@ module Gren.Licenses
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import qualified Json.Decode as D
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import qualified Reporting.Suggest as Suggest
|
||||
import Data.Map qualified as Map
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Reporting.Suggest qualified as Suggest
|
||||
|
||||
-- LICENCES
|
||||
|
||||
|
@ -32,17 +32,17 @@ where
|
||||
|
||||
import Control.Monad (liftM2)
|
||||
import Data.Binary (Binary (..))
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Json.Decode as D
|
||||
import qualified Json.Encode as E
|
||||
import Gren.Package qualified as Pkg
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified System.FilePath as FP
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Variable qualified as Var
|
||||
import System.FilePath qualified as FP
|
||||
import Prelude hiding (maybe)
|
||||
|
||||
-- RAW
|
||||
@ -113,6 +113,7 @@ data Canonical = Canonical
|
||||
{ _package :: !Pkg.Name,
|
||||
_module :: !Name.Name
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- INSTANCES
|
||||
|
||||
@ -169,12 +170,12 @@ debug = Canonical Pkg.core Name.debug
|
||||
-- HTML
|
||||
|
||||
virtualDom :: Canonical
|
||||
virtualDom = Canonical Pkg.virtualDom Name.virtualDom
|
||||
virtualDom = Canonical Pkg.browser Name.virtualDom
|
||||
|
||||
-- JSON
|
||||
|
||||
jsonDecode :: Canonical
|
||||
jsonDecode = Canonical Pkg.json "Json.Decode"
|
||||
jsonDecode = Canonical Pkg.core "Json.Decode"
|
||||
|
||||
jsonEncode :: Canonical
|
||||
jsonEncode = Canonical Pkg.json "Json.Encode"
|
||||
jsonEncode = Canonical Pkg.core "Json.Encode"
|
||||
|
@ -19,10 +19,7 @@ module Gren.Package
|
||||
kernel,
|
||||
core,
|
||||
browser,
|
||||
virtualDom,
|
||||
html,
|
||||
json,
|
||||
http,
|
||||
node,
|
||||
url,
|
||||
--
|
||||
suggestions,
|
||||
@ -38,20 +35,20 @@ where
|
||||
|
||||
import Control.Monad (liftM2)
|
||||
import Data.Binary (Binary, get, put)
|
||||
import qualified Data.Coerce as Coerce
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Coerce qualified as Coerce
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Gren.Version as V
|
||||
import qualified Json.Decode as D
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import Gren.Version qualified as V
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Suggest as Suggest
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Suggest qualified as Suggest
|
||||
import System.FilePath ((</>))
|
||||
|
||||
-- PACKGE NAMES
|
||||
@ -60,7 +57,7 @@ data Name = Name
|
||||
{ _author :: !Author,
|
||||
_project :: !Project
|
||||
}
|
||||
deriving (Ord)
|
||||
deriving (Ord, Show)
|
||||
|
||||
type Author = Utf8.Utf8 AUTHOR
|
||||
|
||||
@ -120,21 +117,9 @@ browser :: Name
|
||||
browser =
|
||||
toName gren "browser"
|
||||
|
||||
virtualDom :: Name
|
||||
virtualDom =
|
||||
toName gren "virtual-dom"
|
||||
|
||||
html :: Name
|
||||
html =
|
||||
toName gren "html"
|
||||
|
||||
json :: Name
|
||||
json =
|
||||
toName gren "json"
|
||||
|
||||
http :: Name
|
||||
http =
|
||||
toName gren "http"
|
||||
node :: Name
|
||||
node =
|
||||
toName gren "node"
|
||||
|
||||
url :: Name
|
||||
url =
|
||||
@ -148,25 +133,22 @@ gren =
|
||||
|
||||
suggestions :: Map.Map Name.Name Name
|
||||
suggestions =
|
||||
let random = toName gren "random"
|
||||
time = toName gren "time"
|
||||
file = toName gren "file"
|
||||
in Map.fromList
|
||||
[ "Browser" ==> browser,
|
||||
"File" ==> file,
|
||||
"File.Download" ==> file,
|
||||
"File.Select" ==> file,
|
||||
"Html" ==> html,
|
||||
"Html.Attributes" ==> html,
|
||||
"Html.Events" ==> html,
|
||||
"Http" ==> http,
|
||||
"Json.Decode" ==> json,
|
||||
"Json.Encode" ==> json,
|
||||
"Random" ==> random,
|
||||
"Time" ==> time,
|
||||
"Url.Parser" ==> url,
|
||||
"Url" ==> url
|
||||
]
|
||||
Map.fromList
|
||||
[ "Browser" ==> browser,
|
||||
"File" ==> browser,
|
||||
"File.Download" ==> browser,
|
||||
"File.Select" ==> browser,
|
||||
"Html" ==> browser,
|
||||
"Html.Attributes" ==> browser,
|
||||
"Html.Events" ==> browser,
|
||||
"Http" ==> browser,
|
||||
"Json.Decode" ==> core,
|
||||
"Json.Encode" ==> core,
|
||||
"Random" ==> core,
|
||||
"Time" ==> core,
|
||||
"Url.Parser" ==> url,
|
||||
"Url" ==> url
|
||||
]
|
||||
|
||||
(==>) :: [Char] -> Name -> (Name.Name, Name)
|
||||
(==>) moduleName package =
|
||||
|
@ -14,9 +14,9 @@ where
|
||||
|
||||
import Data.Binary (Binary, get, put)
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Utf8 (MBA, copyFromPtr, freeze, newByteArray, writeWord8)
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import GHC.Exts (Ptr, RealWorld)
|
||||
import GHC.IO (stToIO, unsafeDupablePerformIO)
|
||||
import GHC.ST (ST)
|
||||
|
@ -21,14 +21,14 @@ where
|
||||
|
||||
import Control.Monad (liftM3)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import qualified Data.Version as Version
|
||||
import Data.Version qualified as Version
|
||||
import Data.Word (Word16, Word8)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Json.Decode as D
|
||||
import qualified Json.Encode as E
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Paths_gren
|
||||
import Parse.Primitives qualified as P
|
||||
import Paths_gren qualified
|
||||
import Prelude hiding (max)
|
||||
|
||||
-- VERSION
|
||||
|
@ -20,6 +20,7 @@ module Json.Decode
|
||||
pairs,
|
||||
field,
|
||||
--
|
||||
succeed,
|
||||
oneOf,
|
||||
failure,
|
||||
mapError,
|
||||
@ -32,17 +33,17 @@ module Json.Decode
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Internal as B
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import Data.ByteString.Internal qualified as B
|
||||
import Data.Map qualified as Map
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.Word (Word8)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Json.String as Json
|
||||
import qualified Parse.Keyword as K
|
||||
import Json.String qualified as Json
|
||||
import Parse.Keyword qualified as K
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Annotation as A
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- RUNNERS
|
||||
|
||||
@ -279,6 +280,13 @@ findField key pairs =
|
||||
then Just value
|
||||
else findField key remainingPairs
|
||||
|
||||
-- SUCCEED
|
||||
|
||||
succeed :: a -> Decoder x a
|
||||
succeed value =
|
||||
Decoder $ \_ ok _ ->
|
||||
ok value
|
||||
|
||||
-- ONE OF
|
||||
|
||||
oneOf :: [Decoder x a] -> Decoder x a
|
||||
|
@ -23,14 +23,14 @@ module Json.Encode
|
||||
where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Scientific as Sci
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import qualified File
|
||||
import qualified Json.String as Json
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.ByteString.Char8 qualified as BSC
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Scientific qualified as Sci
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import File qualified
|
||||
import Json.String qualified as Json
|
||||
import Prelude hiding (null)
|
||||
|
||||
-- VALUES
|
||||
|
@ -17,18 +17,18 @@ module Json.String
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString.Builder as B
|
||||
import qualified Data.Coerce as Coerce
|
||||
import qualified Data.Name as Name
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Coerce qualified as Coerce
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 (MBA, copyFromPtr, freeze, newByteArray, writeWord8)
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word8)
|
||||
import Foreign.ForeignPtr (withForeignPtr)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import GHC.Exts (RealWorld)
|
||||
import GHC.IO (stToIO, unsafeDupablePerformIO, unsafePerformIO)
|
||||
import GHC.ST (ST)
|
||||
import qualified Parse.Primitives as P
|
||||
import Parse.Primitives qualified as P
|
||||
import Prelude hiding (String)
|
||||
|
||||
-- JSON STRINGS
|
||||
|
@ -3,8 +3,8 @@ module Nitpick.Debug
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Data.Map.Utils as Map
|
||||
import AST.Optimized qualified as Opt
|
||||
import Data.Map.Utils qualified as Map
|
||||
|
||||
-- HAS DEBUG USES
|
||||
|
||||
|
@ -17,17 +17,17 @@ http://moscova.inria.fr/~maranget/papers/warn/warn.pdf
|
||||
|
||||
-}
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified Data.List as List
|
||||
import AST.Canonical qualified as Can
|
||||
import Data.List qualified as List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.String as ES
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Set qualified as Set
|
||||
import Gren.String qualified as ES
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- PATTERN
|
||||
|
||||
@ -172,14 +172,15 @@ checkExpr (A.At region expression) errors =
|
||||
foldr checkDef (checkExpr body errors) defs
|
||||
Can.LetDestruct pattern@(A.At reg _) expr body ->
|
||||
checkPatterns reg BadDestruct [pattern] $
|
||||
checkExpr expr $ checkExpr body errors
|
||||
checkExpr expr $
|
||||
checkExpr body errors
|
||||
Can.Case expr branches ->
|
||||
checkExpr expr $ checkCases region branches errors
|
||||
Can.Accessor _ ->
|
||||
errors
|
||||
Can.Access record _ ->
|
||||
checkExpr record errors
|
||||
Can.Update _ record fields ->
|
||||
Can.Update record fields ->
|
||||
checkExpr record $ Map.foldr checkField errors fields
|
||||
Can.Record fields ->
|
||||
Map.foldr checkExpr errors fields
|
||||
|
@ -5,14 +5,14 @@ module Optimize.Case
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import Control.Arrow (second)
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Optimize.DecisionTree as DT
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Optimize.DecisionTree qualified as DT
|
||||
|
||||
-- OPTIMIZE A CASE EXPRESSION
|
||||
|
||||
|
@ -20,18 +20,18 @@ explains this extraordinarily well! We are currently using the same heuristics
|
||||
as SML/NJ to get nice trees.
|
||||
-}
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import AST.Canonical qualified as Can
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (liftM, liftM2, liftM5)
|
||||
import Data.Binary
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.String as ES
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.String qualified as ES
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- COMPILE CASES
|
||||
|
||||
|
@ -8,16 +8,16 @@ module Optimize.Expression
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Optimize.Case as Case
|
||||
import qualified Optimize.Names as Names
|
||||
import qualified Reporting.Annotation as A
|
||||
import Data.Index qualified as Index
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Optimize.Case qualified as Case
|
||||
import Optimize.Names qualified as Names
|
||||
import Reporting.Annotation qualified as A
|
||||
import Prelude hiding (cycle)
|
||||
|
||||
-- OPTIMIZE
|
||||
@ -124,7 +124,7 @@ optimize cycle (A.At region expression) =
|
||||
do
|
||||
optRecord <- optimize cycle record
|
||||
Names.registerField field (Opt.Access optRecord field)
|
||||
Can.Update _ record updates ->
|
||||
Can.Update record updates ->
|
||||
Names.registerFieldDict updates Opt.Update
|
||||
<*> optimize cycle record
|
||||
<*> traverse (optimizeUpdate cycle) updates
|
||||
|
@ -6,24 +6,24 @@ module Optimize.Module
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Utils.Type as Type
|
||||
import qualified Canonicalize.Effects as Effects
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Utils.Type qualified as Type
|
||||
import Canonicalize.Effects qualified as Effects
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.List as List
|
||||
import Data.List qualified as List
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Optimize.Expression as Expr
|
||||
import qualified Optimize.Names as Names
|
||||
import qualified Optimize.Port as Port
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Main as E
|
||||
import qualified Reporting.Result as Result
|
||||
import qualified Reporting.Warning as W
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Optimize.Expression qualified as Expr
|
||||
import Optimize.Names qualified as Names
|
||||
import Optimize.Port qualified as Port
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Main qualified as E
|
||||
import Reporting.Result qualified as Result
|
||||
import Reporting.Warning qualified as W
|
||||
import Prelude hiding (cycle)
|
||||
|
||||
-- OPTIMIZE
|
||||
|
@ -16,14 +16,14 @@ module Optimize.Names
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
|
||||
-- GENERATOR
|
||||
|
||||
|
@ -8,14 +8,14 @@ module Optimize.Port
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Optimized as Opt
|
||||
import qualified AST.Utils.Type as Type
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Optimized qualified as Opt
|
||||
import AST.Utils.Type qualified as Type
|
||||
import Control.Monad (foldM)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Optimize.Names as Names
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Optimize.Names qualified as Names
|
||||
import Prelude hiding (maybe, null)
|
||||
|
||||
-- ENCODE
|
||||
|
@ -9,21 +9,21 @@ module Parse.Declaration
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import qualified Data.Name as Name
|
||||
import qualified Parse.Expression as Expr
|
||||
import qualified Parse.Keyword as Keyword
|
||||
import qualified Parse.Number as Number
|
||||
import qualified Parse.Pattern as Pattern
|
||||
import AST.Source qualified as Src
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Name qualified as Name
|
||||
import Parse.Expression qualified as Expr
|
||||
import Parse.Keyword qualified as Keyword
|
||||
import Parse.Number qualified as Number
|
||||
import Parse.Pattern qualified as Pattern
|
||||
import Parse.Primitives hiding (State)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.Symbol as Symbol
|
||||
import qualified Parse.Type as Type
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.Symbol qualified as Symbol
|
||||
import Parse.Type qualified as Type
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- DECLARATION
|
||||
|
||||
|
@ -7,20 +7,20 @@ module Parse.Expression
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import qualified Parse.Keyword as Keyword
|
||||
import qualified Parse.Number as Number
|
||||
import qualified Parse.Pattern as Pattern
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Parse.Keyword qualified as Keyword
|
||||
import Parse.Number qualified as Number
|
||||
import Parse.Pattern qualified as Pattern
|
||||
import Parse.Primitives hiding (State)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.String as String
|
||||
import qualified Parse.Symbol as Symbol
|
||||
import qualified Parse.Type as Type
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.String qualified as String
|
||||
import Parse.Symbol qualified as Symbol
|
||||
import Parse.Type qualified as Type
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- TERMS
|
||||
|
||||
@ -168,26 +168,31 @@ record start =
|
||||
oneOf
|
||||
E.RecordOpen
|
||||
[ do
|
||||
word1 0x7D {-}-} E.RecordOpen
|
||||
word1 0x7D {-}-} E.RecordEnd
|
||||
addEnd start (Src.Record []),
|
||||
do
|
||||
starter <- addLocation (Var.lower E.RecordField)
|
||||
expr <- specialize E.RecordUpdateExpr term
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentEquals
|
||||
oneOf
|
||||
E.RecordEquals
|
||||
[ do
|
||||
word1 0x7C E.RecordEquals
|
||||
word1 0x7C {- vertical bar -} E.RecordPipe
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentField
|
||||
firstField <- chompField
|
||||
fields <- chompFields [firstField]
|
||||
addEnd start (Src.Update starter fields),
|
||||
addEnd start (Src.Update expr fields),
|
||||
do
|
||||
word1 0x3D {-=-} E.RecordEquals
|
||||
Space.chompAndCheckIndent E.RecordSpace E.RecordIndentExpr
|
||||
(value, end) <- specialize E.RecordExpr expression
|
||||
Space.checkIndent end E.RecordIndentEnd
|
||||
fields <- chompFields [(starter, value)]
|
||||
addEnd start (Src.Record fields)
|
||||
case expr of
|
||||
A.At exprRegion (Src.Var Src.LowVar name) -> do
|
||||
fields <- chompFields [(A.At exprRegion name, value)]
|
||||
addEnd start (Src.Record fields)
|
||||
A.At (A.Region (A.Position row col) _) _ ->
|
||||
P.Parser $ \_ _ _ _ eerr ->
|
||||
eerr row col E.RecordField
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -32,8 +32,8 @@ where
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (plusPtr)
|
||||
import Parse.Primitives (Col, Parser, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Variable as Var
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Variable qualified as Var
|
||||
|
||||
-- DECLARATIONS
|
||||
|
||||
|
@ -13,20 +13,20 @@ module Parse.Module
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Compiler.Imports as Imports
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Parse.Declaration as Decl
|
||||
import qualified Parse.Keyword as Keyword
|
||||
import AST.Source qualified as Src
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Compiler.Imports qualified as Imports
|
||||
import Gren.Package qualified as Pkg
|
||||
import Parse.Declaration qualified as Decl
|
||||
import Parse.Keyword qualified as Keyword
|
||||
import Parse.Primitives hiding (State, fromByteString)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.Symbol as Symbol
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.Symbol qualified as Symbol
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- FROM BYTE STRING
|
||||
|
||||
|
@ -12,14 +12,14 @@ module Parse.Number
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Utils.Binop as Binop
|
||||
import AST.Utils.Binop qualified as Binop
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Gren.Float as EF
|
||||
import Gren.Float qualified as EF
|
||||
import Parse.Primitives (Col, Parser, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- HELPERS
|
||||
|
||||
|
@ -10,19 +10,19 @@ module Parse.Pattern
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Foreign.Ptr (plusPtr)
|
||||
import qualified Parse.Keyword as Keyword
|
||||
import qualified Parse.Number as Number
|
||||
import Parse.Keyword qualified as Keyword
|
||||
import Parse.Number qualified as Number
|
||||
import Parse.Primitives (Parser, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.String as String
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.String qualified as String
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- TERM
|
||||
|
||||
|
@ -31,14 +31,14 @@ module Parse.Primitives
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Applicative as Applicative (Applicative (..))
|
||||
import qualified Data.ByteString.Internal as B
|
||||
import Control.Applicative qualified as Applicative (Applicative (..))
|
||||
import Data.ByteString.Internal qualified as B
|
||||
import Data.Word (Word16, Word8)
|
||||
import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (Ptr, plusPtr)
|
||||
import Foreign.Storable (peek)
|
||||
import qualified Reporting.Annotation as A
|
||||
import Reporting.Annotation qualified as A
|
||||
import Prelude hiding (length)
|
||||
|
||||
-- PARSER
|
||||
@ -192,6 +192,7 @@ data Snippet = Snippet
|
||||
_offRow :: Row,
|
||||
_offCol :: Col
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a
|
||||
fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) =
|
||||
|
@ -16,15 +16,15 @@ module Parse.Space
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import AST.Source qualified as Src
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word16, Word8)
|
||||
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import Parse.Primitives (Col, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- SPACE PARSING
|
||||
|
||||
|
@ -9,14 +9,14 @@ module Parse.String
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Utf8 as Utf8
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Data.Word (Word16, Word8)
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import qualified Gren.String as ES
|
||||
import qualified Parse.Number as Number
|
||||
import Gren.String qualified as ES
|
||||
import Parse.Number qualified as Number
|
||||
import Parse.Primitives (Col, Parser, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Primitives qualified as P
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- CHARACTER
|
||||
|
||||
|
@ -9,14 +9,14 @@ module Parse.Symbol
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.IntSet as IntSet
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Char qualified as Char
|
||||
import Data.IntSet qualified as IntSet
|
||||
import Data.Name qualified as Name
|
||||
import Data.Vector qualified as Vector
|
||||
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
|
||||
import GHC.Word (Word8)
|
||||
import Parse.Primitives (Col, Parser, Row)
|
||||
import qualified Parse.Primitives as P
|
||||
import Parse.Primitives qualified as P
|
||||
|
||||
-- OPERATOR
|
||||
|
||||
|
@ -8,13 +8,13 @@ module Parse.Type
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Parse.Primitives (Parser, addEnd, addLocation, getPosition, inContext, oneOf, oneOfWithFallback, specialize, word1, word2)
|
||||
import qualified Parse.Space as Space
|
||||
import qualified Parse.Variable as Var
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import Parse.Space qualified as Space
|
||||
import Parse.Variable qualified as Var
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
|
||||
-- TYPE TERMS
|
||||
|
||||
|
@ -19,16 +19,16 @@ module Parse.Variable
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import AST.Source qualified as Src
|
||||
import Data.Char qualified as Char
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Data.Word (Word8)
|
||||
import Foreign.Ptr (Ptr, plusPtr)
|
||||
import GHC.Exts (Char (C#), Int#, chr#, int8ToInt#, uncheckedIShiftL#, word8ToInt8#, (+#), (-#))
|
||||
import GHC.Word (Word8 (W8#))
|
||||
import Parse.Primitives (Col, Parser, Row, unsafeIndex)
|
||||
import qualified Parse.Primitives as P
|
||||
import Parse.Primitives qualified as P
|
||||
|
||||
-- LOCAL UPPER
|
||||
|
||||
|
@ -24,6 +24,7 @@ import Prelude hiding (traverse)
|
||||
|
||||
data Located a
|
||||
= At Region a -- PERF see if unpacking region is helpful
|
||||
deriving (Show)
|
||||
|
||||
instance Functor Located where
|
||||
fmap f (At region a) =
|
||||
@ -47,7 +48,7 @@ data Position
|
||||
= Position
|
||||
{-# UNPACK #-} !Word16
|
||||
{-# UNPACK #-} !Word16
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
at :: Position -> Position -> a -> Located a
|
||||
at start end a =
|
||||
@ -56,7 +57,7 @@ at start end a =
|
||||
-- REGION
|
||||
|
||||
data Region = Region Position Position
|
||||
deriving (Eq)
|
||||
deriving (Eq, Show)
|
||||
|
||||
toRegion :: Located a -> Region
|
||||
toRegion (At region _) =
|
||||
|
@ -63,18 +63,18 @@ module Reporting.Doc
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Gren.Version as V
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Name qualified as Name
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import qualified Json.String as Json
|
||||
import qualified System.Console.ANSI.Types as Ansi
|
||||
import Json.Encode qualified as E
|
||||
import Json.String qualified as Json
|
||||
import System.Console.ANSI.Types qualified as Ansi
|
||||
import System.IO (Handle)
|
||||
import qualified System.Info as Info
|
||||
import qualified Text.PrettyPrint.ANSI.Leijen as P
|
||||
import System.Info qualified as Info
|
||||
import Text.PrettyPrint.ANSI.Leijen qualified as P
|
||||
import Prelude hiding (cycle)
|
||||
|
||||
-- FROM
|
||||
@ -161,10 +161,10 @@ toFancyHint chunks =
|
||||
link :: String -> String -> String -> String -> P.Doc
|
||||
link word before fileName after =
|
||||
P.fillSep $
|
||||
(P.underline (P.text word) <> ":") :
|
||||
map P.text (words before)
|
||||
++ P.text (makeLink fileName) :
|
||||
map P.text (words after)
|
||||
(P.underline (P.text word) <> ":")
|
||||
: map P.text (words before)
|
||||
++ P.text (makeLink fileName)
|
||||
: map P.text (words after)
|
||||
|
||||
fancyLink :: String -> [P.Doc] -> String -> [P.Doc] -> P.Doc
|
||||
fancyLink word before fileName after =
|
||||
@ -183,8 +183,8 @@ reflowLink :: [Char] -> [Char] -> [Char] -> P.Doc
|
||||
reflowLink before fileName after =
|
||||
P.fillSep $
|
||||
map P.text (words before)
|
||||
++ P.text (makeLink fileName) :
|
||||
map P.text (words after)
|
||||
++ P.text (makeLink fileName)
|
||||
: map P.text (words after)
|
||||
|
||||
-- HELPERS
|
||||
|
||||
|
@ -9,26 +9,26 @@ module Reporting.Error
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified File
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import Data.ByteString qualified as B
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import File qualified
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Json.Encode ((==>))
|
||||
import qualified Json.Encode as E
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Error.Canonicalize as Canonicalize
|
||||
import qualified Reporting.Error.Docs as Docs
|
||||
import qualified Reporting.Error.Import as Import
|
||||
import qualified Reporting.Error.Main as Main
|
||||
import qualified Reporting.Error.Pattern as Pattern
|
||||
import qualified Reporting.Error.Syntax as Syntax
|
||||
import qualified Reporting.Error.Type as Type
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import qualified Reporting.Report as Report
|
||||
import qualified System.FilePath as FP
|
||||
import Json.Encode qualified as E
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Error.Canonicalize qualified as Canonicalize
|
||||
import Reporting.Error.Docs qualified as Docs
|
||||
import Reporting.Error.Import qualified as Import
|
||||
import Reporting.Error.Main qualified as Main
|
||||
import Reporting.Error.Pattern qualified as Pattern
|
||||
import Reporting.Error.Syntax qualified as Syntax
|
||||
import Reporting.Error.Type qualified as Type
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
import Reporting.Report qualified as Report
|
||||
import System.FilePath qualified as FP
|
||||
|
||||
-- MODULE
|
||||
|
||||
@ -86,9 +86,9 @@ toDocHelp root module1 modules =
|
||||
""
|
||||
]
|
||||
module2 : otherModules ->
|
||||
moduleToDoc root module1 :
|
||||
toSeparator module1 module2 :
|
||||
toDocHelp root module2 otherModules
|
||||
moduleToDoc root module1
|
||||
: toSeparator module1 module2
|
||||
: toDocHelp root module2 otherModules
|
||||
|
||||
toSeparator :: Module -> Module -> D.Doc
|
||||
toSeparator beforeModule afterModule =
|
||||
@ -129,7 +129,8 @@ toMessageBar title filePath =
|
||||
4 + length title + 1 + length filePath
|
||||
in D.dullcyan $
|
||||
D.fromChars $
|
||||
"-- " ++ title
|
||||
"-- "
|
||||
++ title
|
||||
++ " "
|
||||
++ replicate (max 1 (80 - usedSpace)) '-'
|
||||
++ " "
|
||||
|
@ -13,23 +13,23 @@ module Reporting.Error.Canonicalize
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.OneOrMore as OneOrMore
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Data.Char qualified as Char
|
||||
import Data.Index qualified as Index
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.OneOrMore qualified as OneOrMore
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc (Doc, (<+>))
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Render.Type as RT
|
||||
import qualified Reporting.Report as Report
|
||||
import qualified Reporting.Suggest as Suggest
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Render.Type qualified as RT
|
||||
import Reporting.Report qualified as Report
|
||||
import Reporting.Suggest qualified as Suggest
|
||||
|
||||
-- CANONICALIZATION ERRORS
|
||||
|
||||
@ -134,7 +134,9 @@ toReport source err =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"The type annotation for `" <> Name.toChars name <> "` says it can accept "
|
||||
"The type annotation for `"
|
||||
<> Name.toChars name
|
||||
<> "` says it can accept "
|
||||
<> D.args numTypeArgs
|
||||
<> ", but the definition says it has "
|
||||
<> D.args numDefArgs
|
||||
@ -165,7 +167,11 @@ toReport source err =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"The `" <> Name.toChars name <> "` " <> thing <> " needs "
|
||||
"The `"
|
||||
<> Name.toChars name
|
||||
<> "` "
|
||||
<> thing
|
||||
<> " needs "
|
||||
<> D.args expected
|
||||
<> ", but I see "
|
||||
<> show actual
|
||||
@ -180,7 +186,11 @@ toReport source err =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"The `" <> Name.toChars name <> "` " <> thing <> " needs "
|
||||
"The `"
|
||||
<> Name.toChars name
|
||||
<> "` "
|
||||
<> thing
|
||||
<> " needs "
|
||||
<> D.args expected
|
||||
<> ", but I see "
|
||||
<> show actual
|
||||
@ -328,7 +338,8 @@ toReport source err =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"You are trying to import the `" <> Name.toChars ctor
|
||||
"You are trying to import the `"
|
||||
<> Name.toChars ctor
|
||||
<> "` variant by name:",
|
||||
D.fillSep
|
||||
[ "Try",
|
||||
@ -391,7 +402,8 @@ toReport source err =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"The `" <> Name.toChars home
|
||||
"The `"
|
||||
<> Name.toChars home
|
||||
<> "` module does not expose `"
|
||||
<> Name.toChars value
|
||||
<> "`:",
|
||||
@ -533,7 +545,8 @@ toReport source err =
|
||||
TypeVariable name ->
|
||||
( "an unspecified type",
|
||||
D.reflow $
|
||||
"But type variables like `" <> Name.toChars name
|
||||
"But type variables like `"
|
||||
<> Name.toChars name
|
||||
<> "` cannot flow through ports.\
|
||||
\ I need to know exactly what type of data I am getting, so I can guarantee that\
|
||||
\ unexpected data cannot sneak in and crash the Gren program."
|
||||
@ -624,12 +637,16 @@ toReport source err =
|
||||
"The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop.",
|
||||
D.stack
|
||||
[ makeTheory "Are you trying to mutate a variable?" $
|
||||
"Gren does not have mutation, so when I see " ++ Name.toChars name
|
||||
"Gren does not have mutation, so when I see "
|
||||
++ Name.toChars name
|
||||
++ " defined in terms of "
|
||||
++ Name.toChars name
|
||||
++ ", I treat it as a recursive definition. Try giving the new value a new name!",
|
||||
makeTheory "Maybe you DO want a recursive value?" $
|
||||
"To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name
|
||||
"To define "
|
||||
++ Name.toChars name
|
||||
++ " we need to know what "
|
||||
++ Name.toChars name
|
||||
++ " is, so let’s expand it. Wait, but now we need to know what "
|
||||
++ Name.toChars name
|
||||
++ " is, so let’s expand it... This will keep going infinitely!",
|
||||
@ -645,7 +662,8 @@ toReport source err =
|
||||
"The `" <> Name.toChars name <> "` definition is causing a very tricky infinite loop.",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"The `" <> Name.toChars name
|
||||
"The `"
|
||||
<> Name.toChars name
|
||||
<> "` value depends on itself through the following chain of definitions:",
|
||||
D.cycle 4 name names,
|
||||
D.link
|
||||
@ -666,12 +684,16 @@ toReport source err =
|
||||
"The `" <> Name.toChars name <> "` value is defined directly in terms of itself, causing an infinite loop.",
|
||||
D.stack
|
||||
[ makeTheory "Are you trying to mutate a variable?" $
|
||||
"Gren does not have mutation, so when I see " ++ Name.toChars name
|
||||
"Gren does not have mutation, so when I see "
|
||||
++ Name.toChars name
|
||||
++ " defined in terms of "
|
||||
++ Name.toChars name
|
||||
++ ", I treat it as a recursive definition. Try giving the new value a new name!",
|
||||
makeTheory "Maybe you DO want a recursive value?" $
|
||||
"To define " ++ Name.toChars name ++ " we need to know what " ++ Name.toChars name
|
||||
"To define "
|
||||
++ Name.toChars name
|
||||
++ " we need to know what "
|
||||
++ Name.toChars name
|
||||
++ " is, so let’s expand it. Wait, but now we need to know what "
|
||||
++ Name.toChars name
|
||||
++ " is, so let’s expand it... This will keep going infinitely!",
|
||||
@ -687,7 +709,8 @@ toReport source err =
|
||||
"I do not allow cyclic values in `let` expressions.",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"The `" <> Name.toChars name
|
||||
"The `"
|
||||
<> Name.toChars name
|
||||
<> "` value depends on itself through the following chain of definitions:",
|
||||
D.cycle 4 name names,
|
||||
D.link
|
||||
@ -886,7 +909,10 @@ unboundTypeVars source declRegion tipe typeName allVars (unboundVar, varRegion)
|
||||
++ map (D.green . D.fromName) (unboundVar : map fst unboundVars)
|
||||
++ ["=", "..."],
|
||||
D.reflow $
|
||||
"Why? Well, imagine one `" ++ Name.toChars typeName ++ "` where `" ++ Name.toChars unboundVar
|
||||
"Why? Well, imagine one `"
|
||||
++ Name.toChars typeName
|
||||
++ "` where `"
|
||||
++ Name.toChars unboundVar
|
||||
++ "` is an Int and another where it is a Bool. When we explicitly list the type\
|
||||
\ variables, the type checker can see that they are actually different types."
|
||||
]
|
||||
@ -923,7 +949,8 @@ ambiguousName source region maybePrefix name h hs thing =
|
||||
in ( D.reflow $ "This usage of `" ++ Name.toChars name ++ "` is ambiguous:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"This name is exposed by " ++ show (length possibleHomes)
|
||||
"This name is exposed by "
|
||||
++ show (length possibleHomes)
|
||||
++ " of your imports, so I am not\
|
||||
\ sure which one to use:",
|
||||
D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes,
|
||||
@ -945,7 +972,9 @@ ambiguousName source region maybePrefix name h hs thing =
|
||||
in ( D.reflow $ "This usage of `" ++ toQualString prefix name ++ "` is ambiguous.",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"It could refer to a " ++ thing ++ " from "
|
||||
"It could refer to a "
|
||||
++ thing
|
||||
++ " from "
|
||||
++ eitherOrAny
|
||||
++ " of these imports:",
|
||||
D.indent 4 $ D.vcat $ map homeToYellowDoc possibleHomes,
|
||||
|
@ -10,15 +10,15 @@ module Reporting.Error.Docs
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import Data.Name qualified as Name
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Parse.Primitives (Col, Row)
|
||||
import Parse.Symbol (BadOperator (..))
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Error.Syntax as E
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Report as Report
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Error.Syntax qualified as E
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Report qualified as Report
|
||||
|
||||
data Error
|
||||
= NoDocs A.Region
|
||||
@ -142,12 +142,14 @@ toNameProblemReport source problem =
|
||||
r1
|
||||
r2
|
||||
( D.reflow $
|
||||
"There can only be one `" <> Name.toChars name
|
||||
"There can only be one `"
|
||||
<> Name.toChars name
|
||||
<> "` in your module documentation, but it is listed twice:",
|
||||
"Remove one of them!"
|
||||
)
|
||||
( D.reflow $
|
||||
"There can only be one `" <> Name.toChars name
|
||||
"There can only be one `"
|
||||
<> Name.toChars name
|
||||
<> "` in your module documentation, but I see two. One here:",
|
||||
"And another one over here:",
|
||||
"Remove one of them!"
|
||||
@ -159,7 +161,8 @@ toNameProblemReport source problem =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"I do not see `" <> Name.toChars name
|
||||
"I do not see `"
|
||||
<> Name.toChars name
|
||||
<> "` in the `exposing` list, but it is in your module documentation:",
|
||||
D.reflow $
|
||||
"Does it need to be added to the `exposing` list as well? Or maybe you removed `"
|
||||
@ -173,11 +176,13 @@ toNameProblemReport source problem =
|
||||
region
|
||||
Nothing
|
||||
( D.reflow $
|
||||
"I do not see `" <> Name.toChars name
|
||||
"I do not see `"
|
||||
<> Name.toChars name
|
||||
<> "` in your module documentation, but it is in your `exposing` list:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"Add a line like `@docs " <> Name.toChars name
|
||||
"Add a line like `@docs "
|
||||
<> Name.toChars name
|
||||
<> "` to your module documentation!",
|
||||
D.link "Note" "See" "docs" "for more guidance on writing high quality docs."
|
||||
]
|
||||
|
@ -7,15 +7,15 @@ module Reporting.Error.Import
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Gren.Package as Pkg
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Report as Report
|
||||
import qualified Reporting.Suggest as Suggest
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Report qualified as Report
|
||||
import Reporting.Suggest qualified as Suggest
|
||||
|
||||
-- ERROR
|
||||
|
||||
|
@ -9,14 +9,14 @@ module Reporting.Error.Json
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.UTF8 as BS_UTF8
|
||||
import qualified Data.NonEmptyList as NE
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.UTF8 qualified as BS_UTF8
|
||||
import Data.NonEmptyList qualified as NE
|
||||
import Json.Decode (DecodeExpectation (..), Error (..), ParseError (..), Problem (..), StringProblem (..))
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Exit.Help as Help
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Exit.Help qualified as Help
|
||||
import Reporting.Render.Code qualified as Code
|
||||
|
||||
-- TO REPORT
|
||||
|
||||
@ -335,7 +335,9 @@ expectationToReport path source context (A.Region start end) expectation reason
|
||||
CField field _ ->
|
||||
"I ran into trouble with the value of the \"" ++ BS_UTF8.toString field ++ "\" field:"
|
||||
CIndex index (CField field _) ->
|
||||
"When looking at the \"" ++ BS_UTF8.toString field ++ "\" field, I ran into trouble with the "
|
||||
"When looking at the \""
|
||||
++ BS_UTF8.toString field
|
||||
++ "\" field, I ran into trouble with the "
|
||||
++ D.intToOrdinal index
|
||||
++ " entry:"
|
||||
CIndex index _ ->
|
||||
|
@ -7,15 +7,15 @@ module Reporting.Error.Main
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified Data.Name as Name
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Error.Canonicalize as E
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Render.Type as RT
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import qualified Reporting.Report as Report
|
||||
import AST.Canonical qualified as Can
|
||||
import Data.Name qualified as Name
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Error.Canonicalize qualified as E
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Render.Type qualified as RT
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
import Reporting.Report qualified as Report
|
||||
|
||||
-- ERROR
|
||||
|
||||
@ -85,7 +85,8 @@ toReport localizer source err =
|
||||
E.TypeVariable name ->
|
||||
( "an unspecified type",
|
||||
D.reflow $
|
||||
"But type variables like `" ++ Name.toChars name
|
||||
"But type variables like `"
|
||||
++ Name.toChars name
|
||||
++ "` cannot be given as flags.\
|
||||
\ I need to know exactly what type of data I am getting, so I can guarantee that\
|
||||
\ unexpected data cannot sneak in and crash the Gren program."
|
||||
|
@ -7,14 +7,14 @@ module Reporting.Error.Pattern
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Gren.String as ES
|
||||
import qualified Nitpick.PatternMatches as P
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Report as Report
|
||||
import Data.List qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Gren.String qualified as ES
|
||||
import Nitpick.PatternMatches qualified as P
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Report qualified as Report
|
||||
|
||||
-- TO REPORT
|
||||
|
||||
@ -121,12 +121,14 @@ patternToDoc context pattern =
|
||||
P.Ctor _ "#0" [] ->
|
||||
"()"
|
||||
P.Ctor _ "#2" [a, b] ->
|
||||
"( " <> patternToDoc Unambiguous a
|
||||
"( "
|
||||
<> patternToDoc Unambiguous a
|
||||
<> ", "
|
||||
<> patternToDoc Unambiguous b
|
||||
<> " )"
|
||||
P.Ctor _ "#3" [a, b, c] ->
|
||||
"( " <> patternToDoc Unambiguous a
|
||||
"( "
|
||||
<> patternToDoc Unambiguous a
|
||||
<> ", "
|
||||
<> patternToDoc Unambiguous b
|
||||
<> ", "
|
||||
|
@ -45,17 +45,17 @@ module Reporting.Error.Syntax
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.Name as Name
|
||||
import Data.Char qualified as Char
|
||||
import Data.Name qualified as Name
|
||||
import Data.Word (Word16)
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Numeric (showHex)
|
||||
import Parse.Primitives (Col, Row)
|
||||
import Parse.Symbol (BadOperator (..))
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Report as Report
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Report qualified as Report
|
||||
import Prelude hiding (Char, String)
|
||||
|
||||
-- ALL SYNTAX ERRORS
|
||||
@ -211,7 +211,9 @@ data Record
|
||||
| RecordEnd Row Col
|
||||
| RecordField Row Col
|
||||
| RecordEquals Row Col
|
||||
| RecordPipe Row Col
|
||||
| RecordExpr Expr Row Col
|
||||
| RecordUpdateExpr Expr Row Col
|
||||
| RecordSpace Space Row Col
|
||||
| --
|
||||
RecordIndentOpen Row Col
|
||||
@ -428,6 +430,7 @@ data Number
|
||||
data Space
|
||||
= HasTab
|
||||
| EndlessMultiComment
|
||||
deriving (Show)
|
||||
|
||||
-- TO REPORT
|
||||
|
||||
@ -895,7 +898,8 @@ toWeirdEndReport source row col =
|
||||
( D.reflow $
|
||||
"I ran into an unexpected symbol:",
|
||||
D.reflow $
|
||||
"I was not expecting to see a " ++ op
|
||||
"I was not expecting to see a "
|
||||
++ op
|
||||
++ " here. Try deleting it? Maybe\
|
||||
\ I can give a better hint from there?"
|
||||
)
|
||||
@ -1621,7 +1625,8 @@ toPortReport source port_ startRow startCol =
|
||||
( D.reflow $
|
||||
"I cannot handle ports with names like this:",
|
||||
D.reflow $
|
||||
"You are trying to make a port named `" ++ keyword
|
||||
"You are trying to make a port named `"
|
||||
++ keyword
|
||||
++ "` but that is a reserved word. Try using some other name?"
|
||||
)
|
||||
_ ->
|
||||
@ -1924,7 +1929,8 @@ toTypeAliasReport source typeAlias startRow startCol =
|
||||
"I ran into a reserved word unexpectedly while parsing this type alias:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"It looks like you are trying use `" ++ keyword
|
||||
"It looks like you are trying use `"
|
||||
++ keyword
|
||||
++ "` as a type variable, but it is a reserved word. Try using a different name?",
|
||||
typeAliasNote
|
||||
]
|
||||
@ -2076,7 +2082,8 @@ toCustomTypeReport source customType startRow startCol =
|
||||
"I ran into a reserved word unexpectedly while parsing this custom type:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"It looks like you are trying use `" ++ keyword
|
||||
"It looks like you are trying use `"
|
||||
++ keyword
|
||||
++ "` as a type variable, but it is a reserved word. Try using a different name?",
|
||||
customTypeNote
|
||||
]
|
||||
@ -2422,7 +2429,8 @@ toDeclDefReport source name declDef startRow startCol =
|
||||
surroundings
|
||||
(Just region)
|
||||
( D.reflow $
|
||||
"I just saw the type annotation for `" ++ Name.toChars name
|
||||
"I just saw the type annotation for `"
|
||||
++ Name.toChars name
|
||||
++ "` so I was expecting to see its definition here:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
@ -2630,7 +2638,9 @@ toExprReport source context expr startRow startCol =
|
||||
surroundings
|
||||
(Just region)
|
||||
( D.reflow $
|
||||
"I just saw a " ++ Name.toChars op ++ " "
|
||||
"I just saw a "
|
||||
++ Name.toChars op
|
||||
++ " "
|
||||
++ (if isMath then "sign" else "operator")
|
||||
++ ", so I am getting stuck here:",
|
||||
if isMath
|
||||
@ -3336,7 +3346,8 @@ toLetReport source context let_ startRow startCol =
|
||||
( D.reflow $
|
||||
"I was partway through parsing a `let` expression, but I got stuck here:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a variable name, but\
|
||||
\ it is a reserved word! Try using a different name instead."
|
||||
)
|
||||
@ -3426,7 +3437,8 @@ toLetDefReport source name def startRow startCol =
|
||||
surroundings
|
||||
(Just region)
|
||||
( D.reflow $
|
||||
"I just saw the type annotation for `" ++ Name.toChars name
|
||||
"I just saw the type annotation for `"
|
||||
++ Name.toChars name
|
||||
++ "` so I was expecting to see its definition here:",
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
@ -3679,7 +3691,8 @@ toLetDefReport source name def startRow startCol =
|
||||
( D.reflow $
|
||||
"I got stuck while parsing the `" ++ Name.toChars name ++ "` definition:",
|
||||
D.reflow $
|
||||
"I just saw a type annotation indented " ++ show indent
|
||||
"I just saw a type annotation indented "
|
||||
++ show indent
|
||||
++ " spaces, so I was\
|
||||
\ expecting to see the corresponding definition next with the exact same amount\
|
||||
\ of indentation. It looks like this line needs "
|
||||
@ -3796,7 +3809,8 @@ toCaseReport source context case_ startRow startCol =
|
||||
( D.reflow $
|
||||
"I am partway through parsing a `case` expression, but I got stuck here:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` in one of your\
|
||||
\ patterns, but it is a reserved word. Try using a different name?"
|
||||
)
|
||||
@ -4188,7 +4202,8 @@ toRecordReport source context record startRow startCol =
|
||||
( D.reflow $
|
||||
"I just started parsing a record, but I got stuck on this field name:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a field name, but \
|
||||
\ that is a reserved word. Try using a different name!"
|
||||
)
|
||||
@ -4284,7 +4299,8 @@ toRecordReport source context record startRow startCol =
|
||||
( D.reflow $
|
||||
"I am partway through parsing a record, but I got stuck on this field name:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a field name, but \
|
||||
\ that is a reserved word. Try using a different name!"
|
||||
)
|
||||
@ -4340,7 +4356,7 @@ toRecordReport source context record startRow startCol =
|
||||
"expecting",
|
||||
"to",
|
||||
"see",
|
||||
"another",
|
||||
"a",
|
||||
"record",
|
||||
"field",
|
||||
"defined",
|
||||
@ -4402,8 +4418,48 @@ toRecordReport source context record startRow startCol =
|
||||
noteForRecordError
|
||||
]
|
||||
)
|
||||
RecordPipe row col ->
|
||||
let surroundings = A.Region (A.Position startRow startCol) (A.Position row col)
|
||||
region = toRegion row col
|
||||
in Report.Report "PROBLEM IN RECORD" region [] $
|
||||
Code.toSnippet
|
||||
source
|
||||
surroundings
|
||||
(Just region)
|
||||
( D.reflow $
|
||||
"I am partway through parsing a record, but I got stuck here:",
|
||||
D.stack
|
||||
[ D.fillSep $
|
||||
[ "I",
|
||||
"just",
|
||||
"saw",
|
||||
"an",
|
||||
"expression",
|
||||
"so",
|
||||
"I",
|
||||
"was",
|
||||
"expecting",
|
||||
"to",
|
||||
"see",
|
||||
"a",
|
||||
"|",
|
||||
"symbol",
|
||||
"next.",
|
||||
"So",
|
||||
"try",
|
||||
"putting",
|
||||
"a",
|
||||
D.green "|",
|
||||
"sign",
|
||||
"here?"
|
||||
],
|
||||
noteForRecordError
|
||||
]
|
||||
)
|
||||
RecordExpr expr row col ->
|
||||
toExprReport source (InNode NRecord startRow startCol context) expr row col
|
||||
RecordUpdateExpr expr row col ->
|
||||
toExprReport source context expr row col
|
||||
RecordSpace space row col ->
|
||||
toSpaceReport source space row col
|
||||
RecordIndentOpen row col ->
|
||||
@ -5030,7 +5086,8 @@ toFuncReport source context func startRow startCol =
|
||||
( D.reflow $
|
||||
"I was parsing an anonymous function, but I got stuck here:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as an argument, but\
|
||||
\ it is a reserved word in this language. Try using a different argument name!"
|
||||
)
|
||||
@ -5806,7 +5863,8 @@ toTypeReport source context tipe startRow startCol =
|
||||
( D.reflow $
|
||||
"I was expecting to see a type next, but I got stuck on this reserved word:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a type variable, but \
|
||||
\ it is a reserved word. Try using a different name!"
|
||||
)
|
||||
@ -5911,7 +5969,8 @@ toTRecordReport source context record startRow startCol =
|
||||
( D.reflow $
|
||||
"I just started parsing a record type, but I got stuck on this field name:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a field name, but \
|
||||
\ that is a reserved word. Try using a different name!"
|
||||
)
|
||||
@ -5995,7 +6054,8 @@ toTRecordReport source context record startRow startCol =
|
||||
( D.reflow $
|
||||
"I am partway through parsing a record type, but I got stuck on this field name:",
|
||||
D.reflow $
|
||||
"It looks like you are trying to use `" ++ keyword
|
||||
"It looks like you are trying to use `"
|
||||
++ keyword
|
||||
++ "` as a field name, but \
|
||||
\ that is a reserved word. Try using a different name!"
|
||||
)
|
||||
|
@ -19,18 +19,18 @@ module Reporting.Error.Type
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified Data.Index as Index
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Code as Code
|
||||
import qualified Reporting.Render.Type as RT
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import qualified Reporting.Report as Report
|
||||
import qualified Reporting.Suggest as Suggest
|
||||
import qualified Type.Error as T
|
||||
import AST.Canonical qualified as Can
|
||||
import Data.Index qualified as Index
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Code qualified as Code
|
||||
import Reporting.Render.Type qualified as RT
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
import Reporting.Report qualified as Report
|
||||
import Reporting.Suggest qualified as Suggest
|
||||
import Type.Error qualified as T
|
||||
import Prelude hiding (round)
|
||||
|
||||
-- ERRORS
|
||||
@ -58,7 +58,7 @@ data Context
|
||||
| CallArity MaybeName Int
|
||||
| CallArg MaybeName Index.ZeroBased
|
||||
| RecordAccess A.Region (Maybe Name.Name) A.Region Name.Name
|
||||
| RecordUpdateKeys Name.Name (Map.Map Name.Name Can.FieldUpdate)
|
||||
| RecordUpdateKeys (Map.Map Name.Name Can.FieldUpdate)
|
||||
| RecordUpdateValue Name.Name
|
||||
| Destructure
|
||||
|
||||
@ -171,7 +171,8 @@ toPatternReport source localizer patternRegion category tipe expected =
|
||||
tipe
|
||||
expectedType
|
||||
(addPatternCategory "The argument is a pattern that matches" category)
|
||||
( "But the type annotation on `" <> Name.toChars name
|
||||
( "But the type annotation on `"
|
||||
<> Name.toChars name
|
||||
<> "` says the "
|
||||
<> D.ordinal index
|
||||
<> " argument should be:"
|
||||
@ -217,7 +218,9 @@ toPatternReport source localizer patternRegion category tipe expected =
|
||||
tipe
|
||||
expectedType
|
||||
(addPatternCategory "It is trying to match" category)
|
||||
( "But `" <> Name.toChars name <> "` needs its "
|
||||
( "But `"
|
||||
<> Name.toChars name
|
||||
<> "` needs its "
|
||||
<> D.ordinal index
|
||||
<> " argument to be:"
|
||||
)
|
||||
@ -528,7 +531,8 @@ problemToHint problem =
|
||||
badRigidVar :: Name.Name -> String -> [D.Doc]
|
||||
badRigidVar name aThing =
|
||||
[ D.toSimpleHint $
|
||||
"Your type annotation uses type variable `" ++ Name.toChars name
|
||||
"Your type annotation uses type variable `"
|
||||
++ Name.toChars name
|
||||
++ "` which means ANY type of value can flow through, but your code is saying it specifically wants "
|
||||
++ aThing
|
||||
++ ". Maybe change your type annotation to\
|
||||
@ -539,7 +543,10 @@ badRigidVar name aThing =
|
||||
badDoubleRigid :: Name.Name -> Name.Name -> [D.Doc]
|
||||
badDoubleRigid x y =
|
||||
[ D.toSimpleHint $
|
||||
"Your type annotation uses `" ++ Name.toChars x ++ "` and `" ++ Name.toChars y
|
||||
"Your type annotation uses `"
|
||||
++ Name.toChars x
|
||||
++ "` and `"
|
||||
++ Name.toChars y
|
||||
++ "` as separate type variables. Your code seems to be saying they are the\
|
||||
\ same though. Maybe they should be the same in your type annotation?\
|
||||
\ Maybe your code uses them in a weird way?",
|
||||
@ -572,7 +579,8 @@ badFlexSuper direction super tipe =
|
||||
]
|
||||
T.Type _ name _ ->
|
||||
[ D.toSimpleHint $
|
||||
"I do not know how to compare `" ++ Name.toChars name
|
||||
"I do not know how to compare `"
|
||||
++ Name.toChars name
|
||||
++ "` values. I can only\
|
||||
\ compare ints, floats, chars, strings and arrays of comparable values.",
|
||||
D.reflowLink
|
||||
@ -613,7 +621,9 @@ badRigidSuper super aThing =
|
||||
T.Appendable -> ("appendable", "strings AND arrays")
|
||||
T.CompAppend -> ("compappend", "strings AND arrays")
|
||||
in [ D.toSimpleHint $
|
||||
"The `" ++ superType ++ "` in your type annotation is saying that "
|
||||
"The `"
|
||||
++ superType
|
||||
++ "` in your type annotation is saying that "
|
||||
++ manyThings
|
||||
++ " can flow through, but your code is saying it specifically wants "
|
||||
++ aThing
|
||||
@ -884,7 +894,7 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
]
|
||||
]
|
||||
)
|
||||
RecordUpdateKeys record expectedFields ->
|
||||
RecordUpdateKeys expectedFields ->
|
||||
case T.iteratedDealias tipe of
|
||||
T.Record actualFields ext ->
|
||||
case Map.lookupMin (Map.difference expectedFields actualFields) of
|
||||
@ -892,7 +902,7 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
mismatch
|
||||
( Nothing,
|
||||
"Something is off with this record update:",
|
||||
"The `" <> Name.toChars record <> "` record is",
|
||||
"The record is",
|
||||
"But this update needs it to be compatable with:",
|
||||
[ D.reflow
|
||||
"Do you mind creating an <http://sscce.org/> that produces this error message and\
|
||||
@ -901,19 +911,18 @@ toExprReport source localizer exprRegion category tipe expected =
|
||||
]
|
||||
)
|
||||
Just (field, Can.FieldUpdate fieldRegion _) ->
|
||||
let rStr = "`" <> Name.toChars record <> "`"
|
||||
fStr = "`" <> Name.toChars field <> "`"
|
||||
let fStr = "`" <> Name.toChars field <> "`"
|
||||
in custom
|
||||
(Just fieldRegion)
|
||||
( D.reflow $
|
||||
"The " <> rStr <> " record does not have a " <> fStr <> " field:",
|
||||
"The record does not have a " <> fStr <> " field:",
|
||||
case Suggest.sort (Name.toChars field) (Name.toChars . fst) (Map.toList actualFields) of
|
||||
[] ->
|
||||
D.reflow $ "In fact, " <> rStr <> " is a record with NO fields!"
|
||||
D.reflow $ "In fact, this is a record with NO fields!"
|
||||
f : fs ->
|
||||
D.stack
|
||||
[ D.reflow $
|
||||
"This is usually a typo. Here are the " <> rStr <> " fields that are most similar:",
|
||||
"This is usually a typo. Here are the fields that are most similar:",
|
||||
toNearbyRecord localizer f fs ext,
|
||||
D.fillSep
|
||||
[ "So",
|
||||
@ -1120,7 +1129,8 @@ badOpRightFallback localizer category op tipe expected =
|
||||
(addCategory "The right argument is" category)
|
||||
("But (" <> Name.toChars op <> ") needs the right argument to be:")
|
||||
[ D.toSimpleHint $
|
||||
"With operators like (" ++ Name.toChars op
|
||||
"With operators like ("
|
||||
++ Name.toChars op
|
||||
++ ") I always check the left\
|
||||
\ side first. If it seems fine, I assume it is correct and check the right\
|
||||
\ side. So the problem may be in how the left and right arguments interact!"
|
||||
|
@ -13,21 +13,21 @@ module Reporting.Render.Code
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.UTF8 as UTF8_BS
|
||||
import qualified Data.Char as Char
|
||||
import qualified Data.IntSet as IntSet
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Maybe as Maybe
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import Data.ByteString qualified as B
|
||||
import Data.ByteString.UTF8 qualified as UTF8_BS
|
||||
import Data.Char qualified as Char
|
||||
import Data.IntSet qualified as IntSet
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe qualified as Maybe
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Data.Word (Word16)
|
||||
import Parse.Primitives (Col, Row)
|
||||
import Parse.Symbol (binopCharSet)
|
||||
import Parse.Variable (reservedWords)
|
||||
import qualified Reporting.Annotation as A
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc (Doc)
|
||||
import qualified Reporting.Doc as D
|
||||
import Reporting.Doc qualified as D
|
||||
|
||||
-- CODE
|
||||
|
||||
@ -151,7 +151,8 @@ renderPair source@(Source sourceLines) region1 region2 =
|
||||
in OneLine $
|
||||
D.vcat
|
||||
[ D.fromChars lineNumber <> "| " <> D.fromChars line,
|
||||
D.fromChars spaces1 <> D.red (D.fromChars zigzag1)
|
||||
D.fromChars spaces1
|
||||
<> D.red (D.fromChars zigzag1)
|
||||
<> D.fromChars spaces2
|
||||
<> D.red (D.fromChars zigzag2)
|
||||
]
|
||||
|
@ -13,13 +13,13 @@ module Reporting.Render.Type
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Canonical as Can
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Name as Name
|
||||
import qualified Reporting.Annotation as A
|
||||
import AST.Canonical qualified as Can
|
||||
import AST.Source qualified as Src
|
||||
import Data.Name qualified as Name
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc (Doc, (<+>))
|
||||
import qualified Reporting.Doc as D
|
||||
import qualified Reporting.Render.Type.Localizer as L
|
||||
import Reporting.Doc qualified as D
|
||||
import Reporting.Render.Type.Localizer qualified as L
|
||||
|
||||
-- TO DOC
|
||||
|
||||
|
@ -11,13 +11,13 @@ module Reporting.Render.Type.Localizer
|
||||
)
|
||||
where
|
||||
|
||||
import qualified AST.Source as Src
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Name as Name
|
||||
import qualified Data.Set as Set
|
||||
import qualified Gren.ModuleName as ModuleName
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import AST.Source qualified as Src
|
||||
import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
|
||||
-- LOCALIZER
|
||||
|
||||
|
@ -5,8 +5,8 @@ module Reporting.Report
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Reporting.Annotation as A
|
||||
import qualified Reporting.Doc as D
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
|
||||
-- BUILD REPORTS
|
||||
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user