aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Sil/Check.icl2
-rw-r--r--Sil/Compile.icl56
-rw-r--r--Sil/Error.dcl14
-rw-r--r--Sil/Error.icl32
-rw-r--r--Sil/Parse.icl34
-rw-r--r--Sil/Syntax.dcl17
-rw-r--r--Sil/Syntax.icl31
-rw-r--r--Sil/Types.icl36
8 files changed, 119 insertions, 103 deletions
diff --git a/Sil/Check.icl b/Sil/Check.icl
index b06824b..e17c378 100644
--- a/Sil/Check.icl
+++ b/Sil/Check.icl
@@ -102,7 +102,7 @@ where
findCBs (MachineStm _ _) = []
checkVoid :: (Type, Name) -> [Error]
- checkVoid (TVoid, n) = [Ck_LocalVoid f.f_name n]
+ checkVoid (TVoid, n) = [Ck_LocalVoid (errpos f) n]
checkVoid _ = []
checkErrors :: [(a -> [Error])] a *([Error], Maybe *File) -> *([Error], *Maybe *File)
diff --git a/Sil/Compile.icl b/Sil/Compile.icl
index 6efee77..6475da7 100644
--- a/Sil/Compile.icl
+++ b/Sil/Compile.icl
@@ -198,12 +198,12 @@ where
{asize,bsize=0} -> ((aso + asize, bso), AAddr $ aso + asize)
{asize=0,bsize} -> ((aso, bso + bsize), BAddr $ bso + bsize)
-findVar :: Name -> Gen Address
-findVar n = gets stackoffsets >>= \(aso, bso) ->
+findVar :: ParsePosition Name -> Gen Address
+findVar p n = gets stackoffsets >>= \(aso, bso) ->
gets addresses >>= \addr -> case 'M'.get n addr of
Just (AAddr i) -> comment (n <+ " is on AStack at " <+ i <+ ", with aso " <+ aso <+ " so " <+ (aso-i)) $> AAddr (aso - i)
Just (BAddr i) -> comment (n <+ " is on BStack at " <+ i <+ ", with bso " <+ bso <+ " so " <+ (bso-i)) $> BAddr (bso - i)
- Nothing -> error $ C_UndefinedName n
+ Nothing -> error $ C_UndefinedName (errpos p) n
addFunction :: Function -> Gen ()
addFunction f = modify (\cs -> {cs & symbols='M'.put f.f_name fs cs.symbols})
@@ -239,8 +239,8 @@ getType e = getTypeResolver >>= \tr -> case type tr e of
checkType :: Type Expression -> Gen ()
checkType t e = getType e >>= \t` -> if (t == t`) nop (error $ C_TypeMisMatch t e t`)
-checkTypeName :: Name Expression -> Gen Type
-checkTypeName n e = getType (Name n) >>= \t` -> checkType t` e $> t`
+checkTypeName :: ParsePosition Name Expression -> Gen Type
+checkTypeName pp n e = getType (Name pp n) >>= \t` -> checkType t` e $> t`
tellAbort :: String -> Gen ()
tellAbort s = tell
@@ -396,16 +396,16 @@ where
Nothing -> tell $ repeatn s.asize 'ABC'.Create
Just v -> shrinkStack s *> gen v
s=:{asize=0} -> case init.init_value of
- Nothing -> error $ C_BasicInitWithoutValue init.init_name
+ Nothing -> error $ C_BasicInitWithoutValue (errpos init) init.init_name
Just v -> checkType init.init_type v *> shrinkStack s *> gen v
instance gen Statement
where
- gen st=:(Declaration _ n e) =
- checkTypeName n e >>= \t ->
+ gen st=:(Declaration pp n e) =
+ checkTypeName pp n e >>= \t ->
comment (toString st) *>
gen e *>
- findVar n >>=
+ findVar pp n >>=
updateLoc t
where
updateLoc :: Type Address -> Gen ()
@@ -477,18 +477,18 @@ where
instance gen Expression
where
- gen (Name n) = findVar n >>= getLoc
+ gen (Name p n) = findVar p n >>= getLoc
where
getLoc :: Address -> Gen ()
getLoc (AAddr i) = tell ['ABC'.Push_a $ i] *> growStack {zero & asize=1}
getLoc (BAddr i) = tell ['ABC'.Push_b $ i] *> growStack {zero & bsize=1,btypes=['ABC'.BT_Int]} //TODO check type
- gen (Literal (BLit b)) =
+ gen (Literal _ (BLit b)) =
tell ['ABC'.PushB b] *>
growStack {zero & bsize=1,btypes=['ABC'.BT_Bool]}
- gen (Literal (ILit i)) =
+ gen (Literal _ (ILit i)) =
tell ['ABC'.PushI i] *>
growStack {zero & bsize=1,btypes=['ABC'.BT_Int]}
- gen (App n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
+ gen (App p n args) = gets addresses >>= \addrs -> case 'M'.get n addrs of
Just i -> error C_FunctionOnStack
_ -> gets symbols >>= \syms -> case 'M'.get n syms of
Just fs ->
@@ -500,11 +500,11 @@ where
, 'ABC'.Annotation $ toOAnnot $ typeSize fs.fs_rettype
] *>
growStack (foldl (-~) (typeSize fs.fs_rettype) $ map typeSize fs.fs_argtypes)
- _ -> error $ C_UndefinedName n
- gen (BuiltinApp op arg) =
+ _ -> error $ C_UndefinedName (errpos p) n
+ gen (BuiltinApp _ op arg) =
gen arg *>
gen op
- gen (BuiltinApp2 e1 LogOr e2) =
+ gen (BuiltinApp2 _ e1 LogOr e2) =
checkType TBool e1 *>
checkType TBool e2 *>
fresh "or_true" >>= \true ->
@@ -520,7 +520,7 @@ where
, 'ABC'.PushB True ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
- gen (BuiltinApp2 e1 LogAnd e2) =
+ gen (BuiltinApp2 _ e1 LogAnd e2) =
checkType TBool e1 *>
checkType TBool e2 *>
fresh "and_false" >>= \false ->
@@ -536,24 +536,24 @@ where
, 'ABC'.PushB False ] *>
growStack {zero & bsize=1} *>
tell [ 'ABC'.Label end ]
- gen (BuiltinApp2 e1 Cons e2) =
+ gen (BuiltinApp2 _ e1 Cons e2) =
genToAStack e2 *>
genToAStack e1 *>
tell [ 'ABC'.Raw "\tbuildh\t_Cons\t2" ] *>
shrinkStack {zero & asize=1}
- gen (BuiltinApp2 e1 op e2) =
+ gen (BuiltinApp2 _ e1 op e2) =
mapM gen [e2,e1] *>
gen op
- gen (Tuple i es) =
+ gen (Tuple _ i es) =
comment "Building tuple" *>
mapM genToAStack (reverse es) *>
tell [ 'ABC'.Raw $ "\tbuildh\t_Tuple\t" <+ i ] *>
shrinkStack {zero & asize=i-1}
- gen (List _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
- gen (List t [e:es]) =
+ gen (List _ _ []) = tell ['ABC'.Raw "\tbuildh\t_Nil\t0"] *> growStack {zero & asize=1}
+ gen (List pp t [e:es]) =
getType e >>= \te ->
- gen (BuiltinApp2 e Cons (List (t <|> pure te) es))
- gen e=:(Field f e`)
+ gen (BuiltinApp2 pp e Cons (List pp (t <|> pure te) es))
+ gen e=:(Field _ f e`)
| isTuple =
getType e` >>= \t=:(TTuple arity tes) ->
gen e` *>
@@ -561,7 +561,7 @@ where
, 'ABC'.Pop_a (tupleEl - 1)
, 'ABC'.Update_a 0 (arity - tupleEl)
, 'ABC'.Pop_a (arity - tupleEl) ] *>
- if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField f t) nop *>
+ if (0 >= tupleEl || tupleEl > arity) (error $ T_IllegalField (errpos e) f t) nop *>
case typeSize $ tes!!(tupleEl - 1) of
{bsize=0} -> nop
{btypes} -> mapM (flip toBStack 1) btypes *> nop
@@ -594,7 +594,7 @@ where
, 'ABC'.Pop_a 1 ] *>
growStack {asize=(-1), bsize=1, btypes=['ABC'.BT_Bool]}
| otherwise =
- error $ C_UndefinedField f
+ error $ C_UndefinedField (errpos e) f
where
f` = fromString f
@@ -655,9 +655,9 @@ where
'ABC'.BT_Int -> 'ABC'.FillI_b
genToAStack :: Expression -> Gen ()
-genToAStack (Literal (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
+genToAStack (Literal _ (BLit b)) = tell [ 'ABC'.Raw $ "\tbuildB\t" <+ toABCBool b ] *> growStack {zero & asize=1}
where toABCBool = toString o map toUpper o fromString o toString
-genToAStack (Literal (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
+genToAStack (Literal _ (ILit i)) = tell [ 'ABC'.Raw $ "\tbuildI\t" <+ i ] *> growStack {zero & asize=1}
genToAStack e = getType e >>= \t -> case typeSize t of
{bsize=0} -> gen e
{btypes} -> gen e <* comment "To A-stack" <* mapM BtoAStack btypes <* comment "Done to A-stack"
diff --git a/Sil/Error.dcl b/Sil/Error.dcl
index bdfa390..42341ed 100644
--- a/Sil/Error.dcl
+++ b/Sil/Error.dcl
@@ -19,8 +19,8 @@ instance < ErrorPosition
| E.a: P_Expected ErrorPosition String a & toString a
// Type errors
| T_IllegalApplication Type Type
- | T_IllegalField String Type
- | T_TooHighTupleArity Int
+ | T_IllegalField ErrorPosition String Type
+ | T_TooHighTupleArity ErrorPosition Int
// Check errors
| Ck_NoMainFunction
| Ck_MainFunctionInvalidType ErrorPosition Type
@@ -28,18 +28,18 @@ instance < ErrorPosition
| Ck_DuplicateLocalName ErrorPosition String String
| Ck_ReturnExpressionFromVoid ErrorPosition String
| Ck_NoReturnFromNonVoid ErrorPosition String
- | Ck_LocalVoid String String
+ | Ck_LocalVoid ErrorPosition String
| Ck_BasicGlobal ErrorPosition String
// Compile errors
- | C_UndefinedName String
- | C_UndefinedField String
+ | C_UndefinedName ErrorPosition String
+ | C_UndefinedField ErrorPosition String
| C_VariableLabel
| C_FunctionOnStack
| C_CouldNotDeduceType Expression
| C_TypeMisMatch Type Expression Type
- | C_BasicInitWithoutValue String
+ | C_BasicInitWithoutValue ErrorPosition String
// Miscellaneous
- | UnknownError String
+ | UnknownError String
instance toString Error
instance <<< Error
diff --git a/Sil/Error.icl b/Sil/Error.icl
index fde96ee..e548e33 100644
--- a/Sil/Error.icl
+++ b/Sil/Error.icl
@@ -27,23 +27,23 @@ where
toString (P_Invalid w tk) = "\tInvalid token '" <+ tk <+ "' while parsing a " <+ w <+ "."
toString (P_Expected p s h) = p <+ "Expected " <+ s <+ " near '" <+ h <+ "'."
toString (T_IllegalApplication ft et) = "\tCannot apply a " <+ et <+ " to a " <+ ft <+ "."
- toString (T_IllegalField f t) = "\tIllegal field '" <+ f <+ "' on type " <+ t <+ "."
- toString (T_TooHighTupleArity i) = "\tToo high tuple arity " <+ i <+ " (maximum is 32)."
+ toString (T_IllegalField p f t) = p <+ "Illegal field '" <+ f <+ "' on type " <+ t <+ "."
+ toString (T_TooHighTupleArity p i) = p <+ "Too high tuple arity " <+ i <+ " (maximum is 32)."
toString Ck_NoMainFunction = "\tError: no main function."
toString (Ck_MainFunctionInvalidType p t) = p <+ "Error: function 'main' should not have arguments has type " <+ t <+ "."
toString (Ck_DuplicateFunctionName p n) = p <+ "Error: multiply defined: '" <+ n <+ "'."
toString (Ck_DuplicateLocalName p f arg) = p <+ "Error: multiply defined: '" <+ arg <+ "' in '" <+ f <+ "'."
toString (Ck_ReturnExpressionFromVoid p f) = p <+ "Type error: an expression was returned from void function '" <+ f <+ "'."
toString (Ck_NoReturnFromNonVoid p f) = p <+ "Type error: no return from non-void function '" <+ f <+ "'."
- toString (Ck_LocalVoid f l) = "\tType error: local variable '" <+ l <+ "' in '" <+ f <+ "' cannot have type Void."
+ toString (Ck_LocalVoid p l) = p <+ "Type error: local variable '" <+ l <+ "' cannot have type Void."
toString (Ck_BasicGlobal p g) = p <+ "Error: global variable '" <+ g <+ "' cannot have a basic type."
- toString (C_UndefinedName n) = "\tUndefined name '" <+ n <+ "'."
- toString (C_UndefinedField f) = "\tUndefined field '" <+ f <+ "'."
+ toString (C_UndefinedName p n) = p <+ "Undefined name '" <+ n <+ "'."
+ toString (C_UndefinedField p f) = p <+ "Undefined field '" <+ f <+ "'."
toString C_VariableLabel = "\tVariable stored at label."
toString C_FunctionOnStack = "\tFunction stored on the stack."
- toString (C_CouldNotDeduceType e) = "\tCould not deduce type of '" <+ e <+ "'."
- toString (C_TypeMisMatch t e u) = "\tType mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ u <+ "."
- toString (C_BasicInitWithoutValue n) = "\tBasic value '" <+ n <+ "' must have an initial value."
+ toString (C_CouldNotDeduceType e) = errpos e <+ "Could not deduce type of '" <+ e <+ "'."
+ toString (C_TypeMisMatch t e u) = errpos e <+ "Type mismatch: expected " <+ t <+ " for '" <+ e <+ "'; had " <+ u <+ "."
+ toString (C_BasicInitWithoutValue p n) = p <+ "Basic value '" <+ n <+ "' must have an initial value."
toString (UnknownError e) = "\tUnknown error: " <+ e <+ "."
instance <<< Error where <<< f e = f <<< toString e <<< "\r\n"
@@ -61,23 +61,23 @@ getErrorPosition :: Error -> Maybe ErrorPosition
getErrorPosition (P_Invalid w tk) = Nothing
getErrorPosition (P_Expected p s h) = Just p
getErrorPosition (T_IllegalApplication ft et) = Nothing
-getErrorPosition (T_IllegalField f t) = Nothing
-getErrorPosition (T_TooHighTupleArity i) = Nothing
+getErrorPosition (T_IllegalField p f t) = Just p
+getErrorPosition (T_TooHighTupleArity p i) = Just p
getErrorPosition Ck_NoMainFunction = Nothing
getErrorPosition (Ck_MainFunctionInvalidType p t) = Just p
getErrorPosition (Ck_DuplicateFunctionName p n) = Just p
getErrorPosition (Ck_DuplicateLocalName p f arg) = Just p
getErrorPosition (Ck_ReturnExpressionFromVoid p f) = Just p
getErrorPosition (Ck_NoReturnFromNonVoid p f) = Just p
-getErrorPosition (Ck_LocalVoid f l) = Nothing
+getErrorPosition (Ck_LocalVoid p l) = Just p
getErrorPosition (Ck_BasicGlobal p g) = Just p
-getErrorPosition (C_UndefinedName n) = Nothing
-getErrorPosition (C_UndefinedField f) = Nothing
+getErrorPosition (C_UndefinedName p n) = Just p
+getErrorPosition (C_UndefinedField p f) = Just p
getErrorPosition C_VariableLabel = Nothing
getErrorPosition C_FunctionOnStack = Nothing
-getErrorPosition (C_CouldNotDeduceType e) = Nothing
-getErrorPosition (C_TypeMisMatch t e u) = Nothing
-getErrorPosition (C_BasicInitWithoutValue n) = Nothing
+getErrorPosition (C_CouldNotDeduceType e) = Just (errpos e)
+getErrorPosition (C_TypeMisMatch t e u) = Just (errpos e)
+getErrorPosition (C_BasicInitWithoutValue p n) = Just p
getErrorPosition (UnknownError e) = Nothing
errpos :: a -> ErrorPosition | getPos a
diff --git a/Sil/Parse.icl b/Sil/Parse.icl
index 0f816fe..0d2b913 100644
--- a/Sil/Parse.icl
+++ b/Sil/Parse.icl
@@ -237,33 +237,37 @@ where
op token operator = item token $> operator
rightAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
- rightAssoc opp appp = appp >>= \e1 -> optional (opp >>= \op -> rightAssoc opp appp >>= \e -> pure (op,e))
- >>= pure o maybe e1 (\(op,e2) -> BuiltinApp2 e1 op e2)
+ rightAssoc opp appp = appp >>= \e1 ->
+ optional (opp >>= \op -> getPosition >>= \pos -> rightAssoc opp appp >>= \e -> pure (pos,op,e)) >>=
+ pure o maybe e1 (\(pos,op,e2) -> BuiltinApp2 pos e1 op e2)
leftAssoc :: (Parser Token Op2) (Parser Token Expression) -> Parser Token Expression
- leftAssoc opp appp = appp >>= \e1 -> many (opp >>= \op -> appp >>= \e -> pure (op,e))
- >>= foldM (\e (op,e2) -> pure $ BuiltinApp2 e op e2) e1
+ leftAssoc opp appp = appp >>= \e1 ->
+ many (opp >>= \op -> getPosition >>= \pos -> appp >>= \e -> pure (pos,op,e)) >>=
+ foldM (\e (pos,op,e2) -> pure $ BuiltinApp2 pos e op e2) e1
noInfix :: Parser Token Expression
noInfix
- = liftM2 App name (item TParenOpen *> seplistUntil TParenClose TComma expression)
+ = liftM3 App getPosition name (item TParenOpen *> seplistUntil TParenClose TComma expression)
<|> op TTilde Neg
<|> op TExclamation Not
- <|> (simpleExpr >>= \e -> foldl (flip Field) e <$> many field)
+ <|> (simpleExpr >>= \e -> foldl (flip $ uncurry Field) e <$> many field)
where
op :: Token Op1 -> Parser Token Expression
- op token operator = liftM (BuiltinApp operator) (item token *> noInfix)
+ op token operator = liftM3 BuiltinApp getPosition (pure operator) (item token *> noInfix)
- field :: Parser Token Name
- field = satisfy (\t -> t =: TField _) >>= \(TField f) -> pure f
+ field :: Parser Token (ParsePosition, Name)
+ field = satisfy (\t -> t =: TField _) >>= \(TField f) -> getPosition >>= \p -> pure (p,f)
simpleExpr :: Parser Token Expression
- simpleExpr = liftM Literal literal
- <|> liftM Name name
- <|> flip List [] o pure <$> bracked type
- <|> List Nothing <$> bracked (seplist TComma expression)
- <|> (item TParenOpen *> seplistUntil TParenClose TComma expression >>= \es ->
- pure $ case es of [x] -> x; _ -> Tuple (length es) es)
+ simpleExpr
+ = liftM2 Literal getPosition literal
+ <|> liftM2 Name getPosition name
+ <|> liftM3 List getPosition (pure <$> bracked type) (pure [])
+ <|> liftM3 List getPosition (pure Nothing) (bracked $ seplist TComma expression)
+ <|> (item TParenOpen *> getPosition >>= \pos ->
+ seplistUntil TParenClose TComma expression >>= \es ->
+ pure $ case es of [x] -> x; _ -> Tuple pos (length es) es)
name :: Parser Token Name
name = (\(TName n) -> n) <$> satisfy isName <#> "name"
diff --git a/Sil/Syntax.dcl b/Sil/Syntax.dcl
index 4f0ddf9..b99153e 100644
--- a/Sil/Syntax.dcl
+++ b/Sil/Syntax.dcl
@@ -46,14 +46,14 @@ from Sil.Util.Parser import :: ParsePosition, class getPos
| MachineStm ParsePosition String
:: Expression
- = Name Name
- | Literal Literal
- | App Name [Expression]
- | BuiltinApp Op1 Expression
- | BuiltinApp2 Expression Op2 Expression
- | Field Name Expression
- | Tuple Int [Expression]
- | List (Maybe Type) [Expression]
+ = Name ParsePosition Name
+ | Literal ParsePosition Literal
+ | App ParsePosition Name [Expression]
+ | BuiltinApp ParsePosition Op1 Expression
+ | BuiltinApp2 ParsePosition Expression Op2 Expression
+ | Field ParsePosition Name Expression
+ | Tuple ParsePosition Int [Expression]
+ | List ParsePosition (Maybe Type) [Expression]
:: Op1
= Neg //* ~
@@ -91,6 +91,7 @@ instance toString Literal
instance getPos Function
instance getPos Initialisation
instance getPos Statement
+instance getPos Expression
class allStatements a :: a -> [Statement]
instance allStatements Program
diff --git a/Sil/Syntax.icl b/Sil/Syntax.icl
index e28d616..ce69920 100644
--- a/Sil/Syntax.icl
+++ b/Sil/Syntax.icl
@@ -27,16 +27,16 @@ instance toString Arg where toString arg = arg.arg_type <+ " " <+ arg.arg_name
instance toString Expression
where
- toString (Name n) = n
- toString (Literal lit) = toString lit
- toString (App n args) = n <+ "(" <+ printersperse ", " args <+ ")"
- toString (BuiltinApp op e) = op <+ "(" <+ e <+ ")"
- toString (BuiltinApp2 e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
- toString (Tuple _ es) = "(" <+ printersperse ", " es <+ ")"
- toString (List (Just t) []) = "[" <+ t <+ "]"
- toString (List (Just t) es) = "[" <+ t <+ ":" <+ printersperse ", " es <+ "]"
- toString (List Nothing es) = "[" <+ printersperse ", " es <+ "]"
- toString (Field f e) = "(" <+ e <+ ")." <+ f
+ toString (Name _ n) = n
+ toString (Literal _ lit) = toString lit
+ toString (App _ n args) = n <+ "(" <+ printersperse ", " args <+ ")"
+ toString (BuiltinApp _ op e) = op <+ "(" <+ e <+ ")"
+ toString (BuiltinApp2 _ e1 op e2) = "(" <+ e1 <+ ") " <+ op <+ " (" <+ e2 <+ ")"
+ toString (Tuple _ _ es) = "(" <+ printersperse ", " es <+ ")"
+ toString (List _ (Just t) []) = "[" <+ t <+ "]"
+ toString (List _ (Just t) es) = "[" <+ t <+ ":" <+ printersperse ", " es <+ "]"
+ toString (List _ Nothing es) = "[" <+ printersperse ", " es <+ "]"
+ toString (Field _ f e) = "(" <+ e <+ ")." <+ f
instance toString Op1
where
@@ -77,6 +77,17 @@ where
getPos (While p _ _) = p
getPos (MachineStm p _) = p
+instance getPos Expression
+where
+ getPos (Name p _) = p
+ getPos (Literal p _) = p
+ getPos (App p _ _) = p
+ getPos (BuiltinApp p _ _) = p
+ getPos (BuiltinApp2 p _ _ _) = p
+ getPos (Tuple p _ _) = p
+ getPos (List p _ _) = p
+ getPos (Field p _ _) = p
+
instance allStatements Program
where allStatements p = concatMap allStatements p.p_funs
diff --git a/Sil/Types.icl b/Sil/Types.icl
index 6f802d3..a68a7b8 100644
--- a/Sil/Types.icl
+++ b/Sil/Types.icl
@@ -66,65 +66,65 @@ where
instance type Expression
where
- type res (Name n) = type res n
- type res (Literal lit) = case lit of
+ type res (Name _ n) = type res n
+ type res (Literal _ lit) = case lit of
BLit _ -> Just $ Ok TBool
ILit _ -> Just $ Ok TInt
- type res (App n args) =
+ type res (App _ n args) =
mapM (type res) args >>= \ats ->
res n >>= \ft -> pure
( sequence ats >>= \ats ->
ft >>= \ft -> foldM tryApply ft ats)
- type res (BuiltinApp op e) =
+ type res (BuiltinApp _ op e) =
type res e >>= \te ->
type res op >>= \top -> pure
( top >>= \top ->
te >>= \te -> tryApply top te)
- type res (BuiltinApp2 e1 Cons e2) =
+ type res (BuiltinApp2 _ e1 Cons e2) =
type res e1 >>= \te1 ->
type res e2 >>= \te2 -> pure
( te1 >>= \te1 ->
te2 >>= \te2 ->
let top = te1 --> TList te1 --> TList te1 in
foldM tryApply top [te1,te2])
- type res (BuiltinApp2 e1 op e2) =
+ type res (BuiltinApp2 _ e1 op e2) =
type res e1 >>= \te1 ->
type res e2 >>= \te2 ->
type res op >>= \top -> pure
( top >>= \top ->
te1 >>= \te1 ->
te2 >>= \te2 -> foldM tryApply top [te1,te2])
- type res e=:(List (Just t) es) =
+ type res e=:(List _ (Just t) es) =
mapM (type res) es >>= \tes -> pure
(sequence tes >>= \tes -> case [(e,t`) \\ e <- es & t` <- tes | t <> t`] of
[(e`,t`):_] -> Error $ C_TypeMisMatch t e` t`
[] -> Ok $ TList t)
- type res (List Nothing []) = Nothing
- type res e=:(List Nothing es) =
+ type res (List _ Nothing []) = Nothing
+ type res e=:(List _ Nothing es) =
mapM (type res) es >>= \tes -> pure
(sequence tes >>= \tes -> case removeDup tes of
[t] -> Ok $ TList t
[_:_] -> Error $ C_CouldNotDeduceType e)
- type res (Tuple n es)
- | n > 32 = Just $ Error $ T_TooHighTupleArity n
+ type res e=:(Tuple _ n es)
+ | n > 32 = Just $ Error $ T_TooHighTupleArity (errpos e) n
| otherwise =
mapM (type res) es >>= \ats -> pure (sequence ats >>= pure o TTuple n)
- type res (Field f e)
+ type res fe=:(Field _ f e)
| isTuple = type res e >>= \te -> pure (te >>= \te -> case te of
TTuple arity es -> if (0 < tupleEl && tupleEl <= arity)
(Ok $ es!!(tupleEl - 1))
- (Error $ T_IllegalField f te)
- _ -> Error $ T_IllegalField f te)
+ (Error $ T_IllegalField (errpos fe) f te)
+ _ -> Error $ T_IllegalField (errpos fe) f te)
| f == "hd" = type res e >>= \te -> pure (te >>= \te -> case te of
TList t -> Ok t
- _ -> Error $ T_IllegalField f te)
+ _ -> Error $ T_IllegalField (errpos fe) f te)
| f == "tl" = type res e >>= \te -> pure (te >>= \te -> case te of
t=:(TList _) -> Ok t
- _ -> Error $ T_IllegalField f te)
+ _ -> Error $ T_IllegalField (errpos fe) f te)
| f == "nil" = type res e >>= \te -> pure (te >>= \te -> case te of
(TList _) -> Ok TBool
- _ -> Error $ T_IllegalField f te)
- | otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField f)
+ _ -> Error $ T_IllegalField (errpos fe) f te)
+ | otherwise = type res e >>= \te -> pure (te >>= Error o T_IllegalField (errpos fe) f)
where
f` = fromString f
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:44:35 +0000