Reorganise: make Position a field in Syntax types

11 files changed, 68 insertions, 78 deletions

diff --git a/Sil/Check.icl b/Sil/Check.icl
index c9ccecb..6179a66 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -30,24 +30,24 @@ checkProgram err prog
 	$ appFst flatten $ mapSt (flip checkFunction) prog.p_funs err
 where
 	checkMainFunction :: Program -> [Error]
-	checkMainFunction p = case [f \\ f <- p.p_funs | f.pos_val.f_name == "main"] of
+	checkMainFunction p = case [f \\ f <- p.p_funs | f.f_name == "main"] of
 		[] -> [Ck_NoMainFunction]
 		_  -> []
 
 	checkFunctionNames :: Program -> [Error]
 	checkFunctionNames p =
-		[ Ck_DuplicateFunctionName (errpos $ hd fs) (fromPositioned $ hd fs).f_name
+		[ Ck_DuplicateFunctionName (errpos $ hd fs) (hd fs).f_name
 		\\ fs <- tails [f \\ f <- p.p_funs]
-		| let names = [f.pos_val.f_name \\ f <- fs]
+		| let names = [f.f_name \\ f <- fs]
 		  in  not (isEmpty names) && isMember (hd names) (tl names)]
 
 	checkGlobals :: Program -> [Error]
 	checkGlobals p =
-		[ Ck_BasicGlobal (errpos g) (fromPositioned g).init_name
+		[ Ck_BasicGlobal (errpos g) g.init_name
 		\\ g <- p.p_globals
-		| (typeSize (fromPositioned g).init_type).bsize <> 0]
+		| (typeSize g.init_type).bsize <> 0]
 
-checkFunction :: *(Maybe *File) (Positioned Function) -> *([Error], *Maybe *File)
+checkFunction :: *(Maybe *File) Function -> *([Error], *Maybe *File)
 checkFunction err f = checkErrors
 	[ checkLocals
 	, checkReturnAndVoid
@@ -55,17 +55,17 @@ checkFunction err f = checkErrors
 	] f
 	$ noErrors err
 where
-	checkReturnAndVoid :: (Positioned Function) -> [Error]
-	checkReturnAndVoid p=:{pos_val=f} = case f.f_type of
+	checkReturnAndVoid :: Function -> [Error]
+	checkReturnAndVoid f = case f.f_type of
 		TVoid -> case [st \\ st=:(Return (Just _)) <- allStatements f] of
 			[] -> []
-			_  -> [Ck_ReturnExpressionFromVoid (errpos p) f.f_name]
-		_     -> if (sureToReturn f.f_code) [] [Ck_NoReturnFromNonVoid (errpos p) f.f_name]
+			_  -> [Ck_ReturnExpressionFromVoid (errpos f) f.f_name]
+		_     -> if (sureToReturn f.f_code) [] [Ck_NoReturnFromNonVoid (errpos f) f.f_name]
 	where
 		sureToReturn :: CodeBlock -> Bool
 		sureToReturn cb = case cb.cb_content of
 			[]  -> False
-			sts -> case fromPositioned $ last sts of
+			sts -> case last sts of
 				Return _       -> True
 				While _ cb`    -> sureToReturn cb`
 				If bs (Just e) -> all sureToReturn [e:map snd bs]
@@ -73,27 +73,27 @@ where
 				MachineStm _   -> True // Let's assume the user is not stupid
 				_              -> False
 
-	checkMainFunctionType :: (Positioned Function) -> [Error]
-	checkMainFunctionType {pos_val={f_name="main",f_args=[]}}
+	checkMainFunctionType :: Function -> [Error]
+	checkMainFunctionType {f_name="main",f_args=[]}
 		= []
-	checkMainFunctionType p=:{pos_val=f=:{f_name="main"}}
-		= [Ck_MainFunctionInvalidType (errpos p) $ fromOk $ fromJust $ type zero f]
+	checkMainFunctionType f=:{f_name="main"}
+		= [Ck_MainFunctionInvalidType (errpos f) $ fromOk $ fromJust $ type zero f]
 	checkMainFunctionType _
 		= []
 
-	checkLocals :: (Positioned Function) -> [Error]
-	checkLocals p=:{pos_val=f} =
+	checkLocals :: Function -> [Error]
+	checkLocals f =
 		checkDupName [a.arg_name \\ a <- f.f_args] f.f_code ++
 		concatMap checkVoid (allLocals f)
 	where
 		checkDupName :: [Name] CodeBlock -> [Error]
 		checkDupName defined cb =
-			[Ck_DuplicateLocalName (errpos p) f.f_name l \\ l <- defined | isMember l locals] ++
+			[Ck_DuplicateLocalName (errpos f) f.f_name l \\ l <- defined | isMember l locals] ++
 			concatMap (checkDupName (locals ++ defined)) (underlyingCBs cb)
-		where locals = [(fromPositioned i).init_name \\ i <- cb.cb_init]
+		where locals = [i.init_name \\ i <- cb.cb_init]
 
 		underlyingCBs :: CodeBlock -> [CodeBlock]
-		underlyingCBs cb = concatMap (findCBs o fromPositioned) cb.cb_content
+		underlyingCBs cb = concatMap findCBs cb.cb_content
 		where
 			findCBs (Declaration _ _) = []
 			findCBs (Application _)   = []
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index ced497e..6569dd1 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -264,9 +264,6 @@ where
 
 class gen a :: a -> Gen ()
 
-instance gen (Positioned a) | gen a
-where gen p = gen $ fromPositioned p
-
 instance gen Program
 where
 	gen p =
@@ -280,27 +277,24 @@ where
 		     , 'ABC'.Jmp "_driver"
 		     , 'ABC'.Annotation $ 'ABC'.OAnnot 0 []
 		     , 'ABC'.Label "_sil_boot2" ] *>
-		let gsize = foldr (+~) zero [typeSize i.init_type \\ i <- globs] in
+		let gsize = foldr (+~) zero [typeSize i.init_type \\ i <- p.p_globals] in
 		modify (\cs -> {cs & globalsize=(gsize.asize, gsize.bsize)}) *>
 		shrinkStack gsize *>
-		mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- globs] *>
+		mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- p.p_globals] *>
 		mapM_ gen p.p_globals *>
 		tell [ 'ABC'.Jmp (toLabel "main") ] *>
 		pushTypeResolver typeresolver *>
-		mapM_ (addFunction o fromPositioned) p.p_funs *>
+		mapM_ addFunction p.p_funs *>
 		mapM_ gen p.p_funs *>
 		popTypeResolver
 	where
 		typeresolver :: Name -> Maybe (MaybeError Error Type)
-		typeresolver n = case [f \\ f <- funs | f.f_name == n] of
+		typeresolver n = case [f \\ f <- p.p_funs | f.f_name == n] of
 			[f:_] -> type typeresolver f
-			[]    -> case [g.init_type \\ g <- globs | g.init_name == n] of
+			[]    -> case [g.init_type \\ g <- p.p_globals | g.init_name == n] of
 				[t:_] -> Just $ Ok t
 				[]    -> Nothing
 
-		globs = map fromPositioned p.p_globals
-		funs = map fromPositioned p.p_funs
-
 instance gen Function
 where
 	gen f =
@@ -375,7 +369,7 @@ where
 	gen cb =
 		storeStackOffsets *>
 		gets stackoffsets >>= \so ->
-		mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- init] *>
+		mapM_ reserveVar [(i.init_name, i.init_type) \\ i <- cb.cb_init] *>
 		mapM_ gen cb.cb_init *>
 		addToReturn cleanup` *>
 		pushTypeResolver typeresolver *>
@@ -390,12 +384,10 @@ where
 			_  -> [ 'ABC'.Pop_a locals.asize
 			      , 'ABC'.Pop_b locals.bsize
 			      ]
-		locals = foldr (+~) zero [typeSize i.init_type \\ i <- init]
+		locals = foldr (+~) zero [typeSize i.init_type \\ i <- cb.cb_init]
 
 		typeresolver :: Name -> Maybe (MaybeError Error Type)
-		typeresolver n = listToMaybe [Ok i.init_type \\ i <- init | i.init_name == n]
-
-		init = map fromPositioned cb.cb_init
+		typeresolver n = listToMaybe [Ok i.init_type \\ i <- cb.cb_init | i.init_name == n]
 
 instance gen Initialisation
 where
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index 14427c8..c37e445 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -5,7 +5,7 @@ from StdOverloaded import class toString
 
 from Sil.Syntax import :: Expression
 from Sil.Types import :: Type
-from Sil.Util.Parser import :: Positioned
+from Sil.Util.Parser import :: ParsePosition, class getPos
 
 :: ErrorPosition
 
@@ -40,4 +40,4 @@ from Sil.Util.Parser import :: Positioned
 instance toString Error
 instance <<< Error
 
-errpos :: (Positioned a) -> ErrorPosition
+errpos :: a -> ErrorPosition | getPos a
diff --git a/Sil/Error.icl b/Sil/Error.icl
index ef3e4fa..9253673 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -43,5 +43,5 @@ where
 
 instance <<< Error where <<< f e = f <<< toString e <<< "\r\n"
 
-errpos :: (Positioned a) -> ErrorPosition
-errpos p = {ep_line=p.pos_line}
+errpos :: a -> ErrorPosition | getPos a
+errpos x = {ep_line=(getPos x).pp_line}
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 80bca2b..4a345fe 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -145,18 +145,18 @@ program =
 	eof $>
 	{p_globals=flatten globss, p_funs=fs}
 
-function :: Parser Token (Positioned Function)
+function :: Parser Token Function
 function =
 	type >>= \t ->
-	getPositioner >>= \pos ->
+	getPosition >>= \pos ->
 	name >>= \n ->
 	parenthised (seplist TComma arg) >>= \args ->
-	braced codeblock >>= \cb ->
-	pure $ pos
+	braced codeblock >>= \cb -> pure
 		{ f_type = t
 		, f_name = n
 		, f_args = args
 		, f_code = cb
+		, f_pos  = pos
 		}
 
 codeblock :: Parser Token CodeBlock
@@ -164,25 +164,23 @@ codeblock = many initialisation >>= \is ->
 	many statement >>= \s ->
 	pure {cb_init=flatten is, cb_content=s}
 
-initialisation :: Parser Token [Positioned Initialisation]
+initialisation :: Parser Token [Initialisation]
 initialisation = type >>= \t -> seplist TComma (init t) <* item TSemicolon
 where
 	init t =
-		getPositioner >>= \pos ->
+		getPosition >>= \pos ->
 		name >>= \n ->
-		optional (item TAssign *> expression) >>= \v ->
-		pure $ pos $ {init_type=t, init_name=n, init_value=v}
+		optional (item TAssign *> expression) >>= \v -> pure
+		{init_type=t, init_name=n, init_value=v, init_pos=pos}
 
-statement :: Parser Token (Positioned Statement)
+statement :: Parser Token Statement
 statement =
-	getPositioner >>= \pos ->
-	(   declaration
+	    declaration
 	<|> liftM Application (expression <* item TSemicolon)
 	<|> return
 	<|> if`
 	<|> while
 	<|> machinecode
-	) >>= pure o pos
 where
 	declaration :: Parser Token Statement
 	declaration = liftM2 Declaration name (item TAssign *> expression <* item TSemicolon)
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 1273267..b298c19 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -5,11 +5,11 @@ from StdOverloaded import class toString
 from Data.Maybe import :: Maybe
 
 from Sil.Types import :: Type
-from Sil.Util.Parser import :: Positioned
+from Sil.Util.Parser import :: ParsePosition, class getPos
 
 :: Program =
-	{ p_funs    :: [Positioned Function]
-	, p_globals :: [Positioned Initialisation]
+	{ p_funs    :: [Function]
+	, p_globals :: [Initialisation]
 	}
 
 :: Function =
@@ -17,11 +17,12 @@ from Sil.Util.Parser import :: Positioned
 	, f_name :: Name
 	, f_args :: [Arg]
 	, f_code :: CodeBlock
+	, f_pos  :: ParsePosition
 	}
 
 :: CodeBlock =
-	{ cb_init    :: [Positioned Initialisation]
-	, cb_content :: [Positioned Statement]
+	{ cb_init    :: [Initialisation]
+	, cb_content :: [Statement]
 	}
 
 :: Arg =
@@ -33,6 +34,7 @@ from Sil.Util.Parser import :: Positioned
 	{ init_type  :: Type
 	, init_name  :: Name
 	, init_value :: Maybe Expression
+	, init_pos   :: ParsePosition
 	}
 
 :: Statement
@@ -86,6 +88,9 @@ instance toString Op1
 instance toString Op2
 instance toString Literal
 
+instance getPos Function
+instance getPos Initialisation
+
 class allStatements a :: a -> [Statement]
 instance allStatements Program
 instance allStatements Function
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index a8a0631..0749dde 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -65,14 +65,17 @@ where
 	toString (BLit b) = toString b
 	toString (ILit i) = toString i
 
+instance getPos Function where getPos f = f.f_pos
+instance getPos Initialisation where getPos i = i.init_pos
+
 instance allStatements Program
-where allStatements p = concatMap (allStatements o fromPositioned) p.p_funs
+where allStatements p = concatMap allStatements p.p_funs
 
 instance allStatements Function
 where allStatements f = allStatements f.f_code
 
 instance allStatements CodeBlock
-where allStatements cb = concatMap (allStatements o fromPositioned) cb.cb_content
+where allStatements cb = concatMap allStatements cb.cb_content
 
 instance allStatements Statement
 where
@@ -87,7 +90,7 @@ where
 instance allCodeBlocks Function where allCodeBlocks f = allCodeBlocks f.f_code
 
 instance allCodeBlocks CodeBlock
-where allCodeBlocks cb = [cb:concatMap (allCodeBlocks o fromPositioned) cb.cb_content]
+where allCodeBlocks cb = [cb:concatMap allCodeBlocks cb.cb_content]
 
 instance allCodeBlocks Statement
 where
@@ -102,4 +105,4 @@ where
 		allLocals f.f_code
 
 instance allLocals CodeBlock
-where allLocals cb = [(i.init_type, i.init_name) \\ i <- map fromPositioned cb.cb_init]
+where allLocals cb = [(i.init_type, i.init_name) \\ i <- cb.cb_init]
diff --git a/Sil/Util/Parser.dcl b/Sil/Util/Parser.dcl
index 6f5929c..e5d1cce 100644
--- a/Sil/Util/Parser.dcl
+++ b/Sil/Util/Parser.dcl
@@ -10,14 +10,13 @@ from Data.Maybe import :: Maybe
 
 from Sil.Error import :: Error
 
-:: Positioned a =
-	{ pos_line :: Int
-	, pos_val  :: a
-	}
+:: *ParseState a
 
-fromPositioned :: (Positioned a) -> a
+:: ParsePosition =
+	{ pp_line :: Int
+	}
 
-:: *ParseState a
+class getPos a :: a -> ParsePosition
 
 :: ParseInput a
 	= PI_NewLine
@@ -36,7 +35,7 @@ class name a :: a -> String
 instance name String
 
 runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
-getPositioner :: Parser a (b -> Positioned b)
+getPosition :: Parser a ParsePosition
 (<?>) :: (Parser a b) Error -> Parser a b
 fail :: Parser a b
 top :: Parser a a
diff --git a/Sil/Util/Parser.icl b/Sil/Util/Parser.icl
index 83da78c..92bc08f 100644
--- a/Sil/Util/Parser.icl
+++ b/Sil/Util/Parser.icl
@@ -14,9 +14,6 @@ import Data.Maybe
 
 import Sil.Error
 
-fromPositioned :: (Positioned a) -> a
-fromPositioned p = p.pos_val
-
 :: *ParseState a =
 	{ ps_line    :: Int
 	, ps_input   :: [ParseInput a]
@@ -89,8 +86,8 @@ doPS f = Parser \st -> (Ok (), f st)
 runParser :: (Parser a b) *(ParseState a) -> *(MaybeError Error b, *ParseState a)
 runParser (Parser f) i = f i
 
-getPositioner :: Parser a (b -> Positioned b)
-getPositioner = Parser \st=:{ps_line} -> (Ok \x -> {pos_line=ps_line, pos_val=x}, st)
+getPosition :: Parser a ParsePosition
+getPosition = Parser \st=:{ps_line} -> (Ok {pp_line=ps_line}, st)
 
 (<?>) :: (Parser a b) Error -> Parser a b
 (<?>) p e = Parser \i -> case runParser p i of
diff --git a/Sil/Util/Printer.dcl b/Sil/Util/Printer.dcl
index 56ad103..d0685cb 100644
--- a/Sil/Util/Printer.dcl
+++ b/Sil/Util/Printer.dcl
@@ -3,7 +3,7 @@ definition module Sil.Util.Printer
 from StdOverloaded import class toString, class zero
 
 from Sil.Parse import :: Token
-from Sil.Syntax import :: Positioned, :: Program, :: Function, :: CodeBlock,
+from Sil.Syntax import :: Program, :: Function, :: CodeBlock,
 	:: Initialisation, :: Statement
 
 :: PrintState
@@ -14,7 +14,6 @@ class PrettyPrinter t where
 	print :: PrintState t -> String
 
 instance PrettyPrinter String
-instance PrettyPrinter (Positioned a) | PrettyPrinter a
 instance PrettyPrinter [Token]
 instance PrettyPrinter Program
 instance PrettyPrinter Function
diff --git a/Sil/Util/Printer.icl b/Sil/Util/Printer.icl
index 2a028b6..bcb3c84 100644
--- a/Sil/Util/Printer.icl
+++ b/Sil/Util/Printer.icl
@@ -34,9 +34,6 @@ instance toString PrintState where toString st = {'\t' \\ _ <- [1..st.indent]}
 
 instance PrettyPrinter String where print _ s = s
 
-instance PrettyPrinter (Positioned a) | PrettyPrinter a
-where print st p = print st $ fromPositioned p
-
 instance PrettyPrinter [Token]
 where
 	print st []             = ""