Commit fac4c04a authored by Tim Steenvoorden's avatar Tim Steenvoorden
Browse files

refactor error handling with monad like type synonym

parent aa18f163
......@@ -411,6 +411,20 @@ OtherModules
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
Module
Name: Data.Result
Dir: {Project}/../clean-platform/src/libraries/OS-Independent
Compiler
NeverMemoryProfile: False
NeverTimeProfile: False
StrictnessAnalysis: True
ListTypes: StrictExportTypes
ListAttributes: True
Warnings: True
Verbose: True
ReadableABC: False
ReuseUniqueNodes: True
Fusion: False
Module
Name: Data.Set
Dir: {Project}/../clean-platform/src/libraries/OS-Independent
......
definition module Development.Scrub.Command
from Data.String import class toString, class fromString
:: Command
= Help
| Generate
| Build
| Rebuild
| Deps
| Info
| ResolveModule
| ResolvePackage
//XXX more to come...
instance fromString Command
instance toString Command
import Development.Scrub.Types
run :: String [String] *World -> *World
implementation module Development.Scrub.Command
import Data.Func
import Data.Result
import Data.String
import Data.Tuple
import System.File
import System.Console.Output
......@@ -9,24 +11,6 @@ import System.Console.Output
import Development.Scrub.Manifest
import Development.Scrub.Module
instance fromString Command where
fromString "help" = Help
fromString "deps" = Deps
fromString "generate" = Generate
fromString "build" = Build
fromString "rebuild" = Rebuild
fromString "resolve-module" = ResolveModule
fromString "info" = Info
instance toString Command where
toString Help = "help"
toString Deps = "deps"
toString Generate = "generate"
toString Build = "build"
toString Rebuild = "rebuild"
toString ResolveModule = "resolve-module"
toString Info = "info"
run :: String [String] *World -> *World
run "imports" args world
......@@ -48,8 +32,7 @@ run "resolve-module" args world
= undef
run "info" args world
# (manifest,world) = readMainManifest world
= showManifest manifest world
= showMainManifest world
run "help" args world
= putStrLn helpMessage world
......@@ -57,5 +40,5 @@ run "help" args world
run command args world
= putErr [quote command, " is not a scrub command, see 'scrub help'"] world
helpMessage :== "This is Scrub v0.0.1 by Tim Steenvoorden"
helpMessage :== "This is Scrub v0.0.7 by Tim Steenvoorden"
......@@ -51,10 +51,11 @@ manifestFilename :== "Scrub.json" //FIXME change to .toml
derive JSONDecode Manifest
derive JSONEncode Manifest
readManifest :: FilePath *World -> (Manifest,*World)
readMainManifest :: *World -> (Manifest,*World)
readManifest :: FilePath *World -> *Return Manifest
readMainManifest :: *World -> *Return Manifest
showManifest :: Manifest *World -> *World
writeManifest :: FilePath Manifest *World -> *World
showMainManifest :: *World -> *World
writeManifest :: FilePath Manifest *World -> *Return ()
createPackage :: DependencyInfo *World -> (Package, *World)
createPackage :: DependencyInfo *World -> *Return Package
......@@ -23,51 +23,55 @@ derive JSONEncode Manifest, BasicInfo, DependencyInfo, LibraryInfo, ExecutableIn
// # Manifest files
//
readManifest :: FilePath *World -> (Manifest,*World)
readManifest :: FilePath *World -> *Return Manifest
readManifest path world
# (result,world) = traceAct ["Reading manifest file from", quote path] $
readFile (path </> manifestFilename) world
= case result of
Left error
# world = putErr ["Error reading manifest file from", quote path, ":", toString error] world
= exit 1 world
Right string
# json = fromString string
= case fromJSON json of
Nothing
# world = putErr ["Error parsing manifest file from", quote path] world
= exit 1 world
Just manifest = (manifest, world)
readMainManifest :: *World -> (Manifest,*World)
# world = logInf ["Reading manifest file from", quote path] world
# (result`,world) = readFile (path </> manifestFilename) world
// putErr ["Error reading manifest file from", quote path, ":", toString error] world
| isError result` = (rethrow` result`, world)
# string = fromOk result`
# maybe = fromJSON $ fromString string
| isNothing maybe = (throw $ ParseError "Could not parse manifest file", world)
# manifest = fromJust maybe
= (Ok manifest, world)
readMainManifest :: *World -> *Return Manifest
readMainManifest world
= traceAct ["Reading main manifest file"] $ readManifest "." world
# world = logInf ["Reading main manifest file"] world
= readManifest "." world
showManifest :: Manifest *World -> *World
showManifest manifest world
# world = putInf ["Current manifest:"] world
= putStrLn (toString $ toJSON manifest) world
# world = putAct ["Package information for", manifest.package.BasicInfo.name] world
= putStrLn (jsonPrettyPrint $ toJSON manifest) world
writeManifest :: FilePath Manifest *World -> *World
showMainManifest :: *World -> *World
showMainManifest world
# (result,world) = readMainManifest world
| isError result = world
# manifest = fromOk result
= showManifest manifest world
writeManifest :: FilePath Manifest *World -> *Return ()
writeManifest path manifest world
# (result,world) = traceAct ["Writing manifest file to", quote path] $
writeFile path (toString $ toJSON manifest) world
= case result of
Left error
# world = putErr ["Could not write manifest to", quote path, ":", toString error] world
= snd $ exit 1 world
Right _ = world
# world = logInf ["Writing manifest file to", quote path] world
# (result`,world) = writeFile path (toString $ toJSON manifest) world
// putErr ["Could not write manifest to", quote path, ":", toString error] world
| isError result` = (rethrow` result`, world)//FIXME ugly
= (Ok (), world)
//
// # Packages
//
createPackage :: DependencyInfo *World -> (Package, *World)
createPackage :: DependencyInfo *World -> *Return Package
createPackage info world
# path = info.DependencyInfo.path
# (manifest,world) = readManifest path world
= traceAct ["Creating package info for", quote path] $
({ path = path, manifest = manifest }, world)
# (result,world) = readManifest path world
| isError result = (rethrow result, world)
# manifest = fromOk result
# world = logInf ["Creating package info for", quote path] world
= (Ok { path = path, manifest = manifest }, world)
//
// # Dependencies
......
definition module Development.Scrub.Module
from Data.Either import :: Either
from Data.Result import :: Result, :: Either
from Data.Set import :: Set
from Data.Map import :: Map
......@@ -11,9 +11,9 @@ import Development.Scrub.Types
:: Database :== Map Name FilePath //XXX maybe someday `Map Name Module with Module = {name :: String, version :: Version, path :: FilePath, ..}`
showImports :: FilePath *World -> *World
calcImports :: FilePath *World -> (Either String (Set Name), *World)
parseImports :: String -> Either String (Set Name)
calcImports :: FilePath *World -> *Return (Set Name)
parseImports :: String -> Result Error (Set Name)
showDependencies :: FilePath *World -> *World
calcDependencies :: FilePath Database *World -> (Either String (Set Name), *World)
calcDependencies :: FilePath Database *World -> *Return (Set Name)
......@@ -2,13 +2,15 @@ implementation module Development.Scrub.Module
import Data.Char
import Data.Bool
import Data.Either
import Data.Func
import Data.Maybe
import Data.Result
import Data.String
import Data.Tuple
import Data.Eq
import Data.Ord
import Data.Foldable
import Data.Traversable
import qualified Data.List as List
from Data.List import instance Functor [], instance toString [], instance fromString []
......@@ -17,8 +19,6 @@ import Data.Set.Operators
import qualified Data.Map as Map
from Data.Map import :: Map, instance Semigroup Map, instance Monoid Map
import Data.Foldable
import System.Console.Output
import System.File
import System.FilePath
......@@ -35,23 +35,22 @@ import Development.Scrub.Parsers
showImports :: FilePath *World -> *World
showImports path world
# world = putAct ["Calculating imports of", quote path] world
# (result,world) = calcImports path world
= case result of
Right names -> seqSt putStrLn ('Set'.toList names) world
Left error -> putErr ["Error calculating imports:", error] world
| isError result = putErr [toString $ fromError result] world
# names = fromOk result
= seqSt putStrLn ('Set'.toList names) world
calcImports :: FilePath *World -> (Either String (Set Name), *World)
calcImports :: FilePath *World -> *Return (Set Name)
calcImports path world
# (result,world) = traceAct ["Reading contents of", quote path] $
readFile path world
= (convert result >>= parseImports, world) //FIXME
where
convert :: (Either FileError a) -> Either String a
convert (Left e) = Left (toString e)
convert (Right a) = Right a
# world = logInf ["Reading contents of", quote path] world
# (result,world) = readFile path world
| isError result = (rethrow` result, world)
# string = fromOk result
= (parseImports string, world)
parseImports :: String -> Either String (Set Name)
parseImports string = 'Set'.fromList <$> parseOnly imports string
parseImports :: String -> Result Error (Set Name)
parseImports string = mapBoth ParseError 'Set'.fromList $ parseOnly imports string
//
// ## Imports parser
......@@ -82,41 +81,42 @@ imports = concat <$> many (importLine <|> fromLine <|> otherLine)
// # Calculating dependencies
//
// showDependencies path = readMainManifest >>= createDatabase >>= calcDependencies path >>= showDatabase
showDependencies :: FilePath *World -> *World
showDependencies path world
# (manifest,world) = readMainManifest world
# (database,world) = createDatabase manifest world
# world = logAct ["Calculating dependecies of", quote path] world
# (result,world) = readMainManifest world
| isError result = world
# manifest = fromOk result
# (result,world) = createDatabase manifest world
| isError result = world
# database = fromOk result
# (result,world) = calcDependencies path database world
= case result of
Right names -> seqSt putStrLn ('Set'.toList names) world //FIXME DRY
Left error -> putErr ["Error calculating dependencies:", error] world
| isError result = putErr [toString $ fromError result] world
# names = fromOk result
= seqSt putStrLn ('Set'.toList names) world
//TODO optimise by collecting in DependencyTree
calcDependencies :: FilePath Database *World -> (Either String (Set Name), *World)
//TODO optimise by collecting in DependencyTree ?
calcDependencies :: FilePath Database *World -> *Return (Set Name)
calcDependencies path database world
# (result,world) = traceAct ["Calculating dependencies of", quote path] $
calcImports path world
= case result of
Right todo -> go todo 'Set'.empty world
error -> (error, world)
# (result,world) = calcImports path world
| isError result = (result, world)
# todo = fromOk result
= go todo 'Set'.empty world
where
// go :: (Set a) (Set a) *World -> (Either String (Set Name), *World)
// go :: (Set a) -> (Set a) *World -> *Return (Set Name)
go todo done world
| 'Set'.null todo = (pure done, world)
| 'Set'.null todo = (Ok done, world)
# (current,rest) = 'Set'.deleteFindMin todo
# pathE = lookupDatabase current database
= case pathE of
Right path
# (importsE,world) = calcImports path world
# todoE = importsE >>= \imports ->
pure $ rest \/ imports \\\ done
# done = 'Set'.insert current done
= case todoE of
Right todo = go todo done world
error = (error, world)
Left e = (Left e, world)
throw e :== Left e
# result = lookupModule current database
| isError result = (rethrow result, world)
# path = fromOk result
# (result,world) = calcImports path world
| isError result = (result, world)
# imports = fromOk result
# todo = rest \/ imports \\\ done
# done = 'Set'.insert current done
= go todo done world
//
// # Module database
......@@ -129,40 +129,45 @@ moduleSeparator :== '.'
replace :: Char Char -> String -> String
replace x y = toString o 'List'.map (\e -> e == x ? y $ e) o fromString
createDatabase :: Manifest *World -> (Database, *World)
createDatabase :: Manifest *World -> *Return Database
createDatabase manifest world
# (packages,world) = mapSt createPackage manifest.dependencies world
# world = logInf ["Creating main module database"] world
# (results,world) = mapSt createPackage manifest.dependencies world
# result = sequence results
| isError result = (rethrow result, world)
# packages = fromOk result
# (result,world) = localModules manifest world
= case result of
Left error
# world = putErr ["Error creating database:", error] world
= exit 1 world
Right database
= traceAct ["Creating main module database"] $
('List'.foldr extendDatabase database packages, world)
| isError result = (result, world)
// putErr ["Error creating database:", error] world
# database = fromOk result
= (Ok $ 'List'.foldr extendDatabase database packages, world)
// createDatabase manifest world
// tell [Info "Creating main module database"]
// packages <- sequence $ traverse createPackage manifest.dependencies
// database <- localModules manifest
// return $ 'List'.foldr extendDatabase database packages
extendDatabase :: Package Database -> Database
extendDatabase package database
= traceAct ["Extending module database with", quote package.manifest.package.BasicInfo.name] $
'List'.foldr (uncurry 'Map'.insert) database $ 'List'.zip2 moduleNames definitionPaths
// traceAct ["Extending module database with", quote package.manifest.package.BasicInfo.name] $
= 'List'.foldr (uncurry 'Map'.insert) database $ 'List'.zip2 moduleNames definitionPaths
where
moduleNames = maybe [] (\info -> info.modules) package.manifest.library
definitionPaths = 'List'.map transform moduleNames
transform name = package.Package.path </> maybe "" id package.manifest.package.sources </> replace moduleSeparator pathSeparator name <.> definitionExtension
//XXX someday: transform name = scrubPackageRoot </> package.name </> package.version </> package.sources </> replace moduleSeparator pathSeparator name <.> definitionExtension
localModules :: Manifest *World -> (Either String Database, *World)
localModules :: Manifest *World -> *Return Database
localModules manifest world
# world = logInf ["Searching for local modules"] world
# world = logRes ["Source directory"] sourceDir world
# (result,world) = findFiles definitionPredicate sourceDir world
= case result of
Left error = (throw $ "Some OSError...", world)
Right definitionPaths
# moduleNames = traceRes ["Found local modules"] $
'List'.map transform definitionPaths
= traceAct ["Searching for local modules"] $
(pure $ 'Map'.fromList $ //traceRes ["Local modules"] $
'List'.zip2 moduleNames definitionPaths
, world)
| isError result = (rethrow` result, world)
# definitionPaths = fromOk result
# moduleNames = 'List'.map transform definitionPaths
# world = logRes ["Found local modules"] moduleNames world
= (Ok $ 'Map'.fromList $ 'List'.zip2 moduleNames definitionPaths, world)
where
sourceDir = maybe "./src" id manifest.package.sources
transform = replace pathSeparator moduleSeparator o makeRelative sourceDir o dropExtension
......@@ -180,9 +185,9 @@ localModules manifest world
// ## Resolving module definitionPaths
//
lookupDatabase :: Name Database -> Either String FilePath
lookupDatabase module database
lookupModule :: Name Database -> Result Error FilePath
lookupModule module database
= case 'Map'.lookup module database of
Nothing -> throw $ "Could not find module " +++ quote module +++ " in packages"
Just path -> pure path
Nothing -> Error $ LookupError $ "Could not find module " +++ quote module +++ " in packages"
Just path -> Ok path
definition module Development.Scrub.Parsers
import Data.Either
import Data.Functor
import Data.String
import Data.Eq
import Data.Functor
from Control.Applicative import class Applicative(..), class Alternative(..), *>, <*
import Text.Parsers.Parsers
from Text.Parsers.Parsers import :: Parser,
symbol, token, <!*>, <!+>, <!?>, number, satisfy,
instance Functor Parser, instance Applicative Parser, instance Alternative Parser
import Development.Scrub.Types
// Parser -- Run //
......
......@@ -15,14 +15,16 @@ from Control.Applicative import class Applicative(..), class Alternative(..), *>
import Text.Parsers.Parsers
from Development.Scrub.Types import :: Error(..), :: FileError, :: OSError, :: OSErrorMessage, :: OSErrorCode
// Parser -- Run //
parseOnly :: (Parser Char r r) String -> Either String r
parseOnly parser input = toEither $ parse parser (fromString input) "parseOnly" "character"
where
toEither :: (Result r) -> Either String r
toEither (Succ rs) = Right ('List'.head rs) //XXX uses `head`: unsafe for these parsers?
toEither (Err a b c) = Left "!! Parse error" //(toString (a,b,c))
toEither (Succ rs) = Right ('List'.head rs) //XXX uses `head`, but because these are non-deterministic parsers it is ok?
toEither (Err a b c) = Left "Parser combinators failed" //(toString (a,b,c))
// Parser -- Helpers //
......
definition module Development.Scrub.Types
from Data.Either import :: Either
from Data.Func import $
from Data.Result import :: Result, :: Either(..), fromLeft
from Data.Maybe import :: Maybe
from Data.String import class toString(..)
from Text.JSON import generic JSONDecode, generic JSONEncode, :: JSONNode(..)
from System.File import :: FileError
from System.IO import :: IO
from System.OSError import :: OSError, :: OSErrorCode, :: OSErrorMessage
import System.Console.Output
//
// # The `Run` monad
//
// :: Run a :== WriterT [Message] (ExceptT Error (IO)) a
// :: Run a :== ExceptT Error (WriterT [Message] (IO)) a
// :: Run a :== *World -> (([Message], Either Error a), *World)
/// The `Run` monad is essentially an Exception monad stacked on top of the IO
/// monad. Sadly monad transformers in Clean are heavy (because they are boxed)
/// and ugly (because there is no do-notation). Therefore we define this as a
/// type-macro and use let-before syntax to pack and unpack this structure.
// TODO:
// Replace alle instances of `*World -> Return` with `Run`
// after new let-before syntax extension is introduced.
// (Apperently this violates strictness analysis...)
// :: Run a :== *World -> (Either Error a, *World)
:: Return a :== .(Either Error a, .World)
:: Error
= SystemError OSError
| FileError FileError
| LookupError String
| ParseError String
| NinjaError String
// | ...
instance toString Error
//
// # Type casting
//
/// Class to cast arbitrary types to each other
class Cast a b where
cast :: a -> b
// instance Cast (Either e a) (Either e` a) | Cast e e`
instance Cast OSError Error
instance Cast FileError Error
rethrow` e :== Left $ cast $ fromLeft e
//
// # Type synonyms
//
:: Name :== String
:: Address :== String
:: Version = Version Major Minor Micro // major, minor, micro
:: Version = Version Major Minor Micro
:: Major :== Int
:: Minor :== Int
:: Micro :== Int
......@@ -18,9 +73,35 @@ from Text.JSON import generic JSONDecode, generic JSONEncode, :: JSONNode(..)
:: VersionConstraint :== String
//
// ## Instances
//
instance toString Version
parseVersion :: String -> Either String Version
derive JSONDecode Version //instance in .icl
derive JSONEncode Version //instance in .icl
derive JSONDecode Error, Either
derive JSONEncode Error, Either
//
// # Logging
//
// logAct, logRes, logErr, logWrn, logInf :: [String] *World -> *World
//NOTE Doesn't work with `?` `$` operators because macro expansion is after sharing inference...