refactor error handling with monad like type synonym

scrub.prj

@@ -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

src/Development/Scrub/Command.dcl

 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
 

src/Development/Scrub/Command.icl

 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"
 

src/Development/Scrub/Manifest.dcl

@@ -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
 

src/Development/Scrub/Manifest.icl

@@ -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

src/Development/Scrub/Module.dcl

 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)
 

src/Development/Scrub/Module.icl

@@ -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
 

src/Development/Scrub/Parsers.dcl

 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 //
 

src/Development/Scrub/Parsers.icl

@@ -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 //
 

src/Development/Scrub/Types.dcl

 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...
+