Remove aborts in Snug.Compile, use MonadFail instead

1 files changed, 39 insertions, 34 deletions

diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 645c9ed..de7078a 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -3,8 +3,11 @@ implementation module Snug.Compile
 import StdEnv
 
 import Control.Monad
+import Control.Monad.Fail
+import Control.Monad.State
 import Data.Error
 import Data.Func
+import Data.Functor
 import Data.List
 import qualified Data.Map
 from Data.Map import :: Map
@@ -14,6 +17,8 @@ import Snug.Compile.ABI
 import Snug.Compile.Simulate
 import Snug.Syntax
 
+:: CompileM a :== MaybeError String a
+
 :: Locals :== Map SymbolIdent LocalLocation
 
 :: LocalLocation = FrontPtrArg !Int
@@ -29,9 +34,9 @@ where
 		| x.id > y.id = False
 		| otherwise = x.ns < y.ns
 
-compile :: !Namespace ![Definition] -> [Line]
+compile :: !Namespace ![Definition] -> MaybeError String [Line]
 compile ns defs =
-	concatMap (compileDefinition ns globals) defs
+	flatten <$> mapM (compileDefinition ns globals) defs
 where
 	globals = combineGlobals
 		[ builtin
@@ -70,29 +75,29 @@ lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors
 lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
 lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions
 
-compileDefinition :: !Namespace !Globals !Definition -> [Line]
-compileDefinition _ _ (TypeDef _ _) =
+compileDefinition :: !Namespace !Globals !Definition -> CompileM [Line]
+compileDefinition _ _ (TypeDef _ _) = pure
 	[]
 compileDefinition ns globals (DataDef _ _ constructors) =
-	[ StartSection "data"
-	: concatMap (compileConstructor ns globals) constructors
-	]
+	(++) [StartSection "data"] <$>
+	flatten <$> mapM (compileConstructor ns globals) constructors
 compileDefinition ns globals (FunDef id args ret expr) =
-	[ StartSection "text"
-	, Global label
-	// TODO: Ideally we would use the following here:
-	//, Align 1
-	//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
-	//, RawByte (length args) // arity
-	// But since SPIM does not allow .byte in the text section, we use:
-	, Align 2
-	, RawWord
-		(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
-		(length args << 8)) // arity
-	// instead... (end modification)
-	, Label label
-	: map Instr (compileExpr ns globals locals expr)
-	]
+	(++)
+		[ StartSection "text"
+		, Global label
+		// TODO: Ideally we would use the following here:
+		//, Align 1
+		//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
+		//, RawByte (length args) // arity
+		// But since SPIM does not allow .byte in the text section, we use:
+		, Align 2
+		, RawWord
+			(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
+			(length args << 8)) // arity
+		// instead... (end modification)
+		, Label label
+		] <$>
+	map Instr <$> compileExpr ns globals locals expr
 where
 	label = functionLabel ns NodeEntry id
 	locals = 'Data.Map'.fromList
@@ -101,8 +106,8 @@ where
 		& offset <- [0..]
 		]
 
-compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
-compileConstructor ns _ (ConstructorDef id args) =
+compileConstructor :: !Namespace !Globals !ConstructorDef -> CompileM [Line]
+compileConstructor ns _ (ConstructorDef id args) = pure
 	[ Global label
 	, Align 1
 	, Label label
@@ -113,11 +118,11 @@ compileConstructor ns _ (ConstructorDef id args) =
 where
 	label = constructorLabel ns id
 
-compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
+compileExpr :: !Namespace !Globals !Locals !Expression -> CompileM [Instruction]
 compileExpr ns globals locals expr =
 	case simulate [SVRegOffset FrontEvalPtr 0] expr` of
-		Error e -> abort ("Compiling an expression failed: " +++ e +++ "\n")
-		Ok instrs -> instrs
+		Error e -> fail ("Compiling an expression failed: " +++ e)
+		Ok instrs -> pure instrs
 where
 	expr` = simulator ns globals locals expr >>| indirectAndEval
 
@@ -134,31 +139,31 @@ simulator ns globals locals (Symbol id) =
 			stackSize >>= \n ->
 			pushArg (n-1) i
 		?None -> case lookupFunction ns id globals of
-			?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
+			?None -> fail ("unknown symbol: " +++ id)
 			?Just info ->
 				case info.arity of
 					0 ->
 						buildThunk (functionLabel ns NodeEntry id) 0
 					_ ->
-						abort "symbol with arity > 0\n" // TODO implement
+						fail "symbol with arity > 0" // TODO implement
 simulator ns globals locals expr=:(ExpApp _ _) =
 	case f of
 		Symbol id -> // TODO include locals
 			case lookupFunction ns id globals of
-				?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
+				?None -> fail ("unknown symbol: " +++ id)
 				?Just info | info.arity == length args ->
 					mapM_ (simulator ns globals locals) (reverse args) >>|
 					buildThunk (functionLabel ns NodeEntry id) info.arity
-				_ -> abort ("arity mismatch in application\n") // TODO implement
+				_ -> fail "arity mismatch in application" // TODO implement
 		Constructor id ->
 			case lookupConstructor ns id globals of
-				?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up
+				?None -> fail ("unknown constructor: " +++ id)
 				?Just (ConstructorDef _ arg_types) | length arg_types == length args ->
 					mapM_ (simulator ns globals locals) (reverse args) >>|
 					buildCons (constructorLabel ns id) (length args)
-				_ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement
+				_ -> fail ("arity mismatch in application of " +++ id) // TODO implement
 		_ -> // TODO
-			abort "unexpected lhs of function application\n"
+			fail "unexpected lhs of function application"
 where
 	(f, args) = linearizeApp expr []