diff --git a/src/AssignTypes.hs b/src/AssignTypes.hs
index 44b0ea5af..9d1730da5 100644
--- a/src/AssignTypes.hs
+++ b/src/AssignTypes.hs
@@ -1,56 +1,33 @@
-module AssignTypes where
+-- | Module AssignTypes defines routines for replacing type variables with
+-- concrete types.
+module AssignTypes
+ ( assignTypes,
+ beautifyTypeVariables,
+ )
+where
import Data.List (nub)
+import Forms
import qualified Map
import Obj
import TypeError
import Types
+--------------------------------------------------------------------------------
+-- Public functions
+
{-# ANN assignTypes "HLint: ignore Eta reduce" #-}
--- | Walk the whole expression tree and replace all occurences of VarTy with their corresponding actual type.
+-- | Walk the whole expression tree and replace all occurrences of VarTy with
+-- their corresponding actual type.
assignTypes :: TypeMappings -> XObj -> Either TypeError XObj
-assignTypes mappings root = visit root
- where
- visit xobj =
- case xobjObj xobj of
- (Lst _) -> visitList xobj
- (Arr _) -> visitArray xobj
- (StaticArr _) -> visitStaticArray xobj
- _ -> assignType xobj
- visitList :: XObj -> Either TypeError XObj
- visitList (XObj (Lst xobjs) i t) =
- do
- visited <- mapM (assignTypes mappings) xobjs
- let xobj' = XObj (Lst visited) i t
- assignType xobj'
- visitList _ = error "The function 'visitList' only accepts XObjs with lists in them."
- visitArray :: XObj -> Either TypeError XObj
- visitArray (XObj (Arr xobjs) i t) =
- do
- visited <- mapM (assignTypes mappings) xobjs
- let xobj' = XObj (Arr visited) i t
- assignType xobj'
- visitArray _ = error "The function 'visitArray' only accepts XObjs with arrays in them."
- visitStaticArray :: XObj -> Either TypeError XObj
- visitStaticArray (XObj (StaticArr xobjs) i t) =
- do
- visited <- mapM (assignTypes mappings) xobjs
- let xobj' = XObj (StaticArr visited) i t
- assignType xobj'
- visitStaticArray _ = error "The function 'visitStaticArray' only accepts XObjs with arrays in them."
- assignType :: XObj -> Either TypeError XObj
- assignType xobj = case xobjTy xobj of
- Just startingType ->
- let finalType = replaceTyVars mappings startingType
- in if isArrayTypeOK finalType
- then Right (xobj {xobjTy = Just finalType})
- else Left (ArraysCannotContainRefs xobj)
- Nothing -> pure xobj
-
-isArrayTypeOK :: Ty -> Bool
-isArrayTypeOK (StructTy (ConcreteNameTy (SymPath [] "Array")) [RefTy _ _]) = False -- An array containing refs!
-isArrayTypeOK _ = True
+assignTypes mappings x@(ListPat xs) =
+ mapM (assignTypes mappings) xs >>= pure . (setObj x) . Lst
+assignTypes mappings x@(ArrPat xs) =
+ mapM (assignTypes mappings) xs >>= pure . (setObj x) . Arr
+assignTypes mappings x@(StaticArrPat xs) =
+ mapM (assignTypes mappings) xs >>= pure . (setObj x) . StaticArr
+assignTypes mappings x = assignType mappings x
-- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...)
-- | TODO: Only change variables that are machine generated.
@@ -65,3 +42,25 @@ beautifyTypeVariables root =
(map (VarTy . (: [])) ['a' ..])
)
in assignTypes mappings root
+
+--------------------------------------------------------------------------------
+-- Private functions
+
+-- | Replace a type variable with a concrete type, ensuring refs aren't passed
+-- as members of arrays.
+assignType :: TypeMappings -> XObj -> Either TypeError XObj
+assignType mappings xobj =
+ case xobjTy xobj of
+ Just startingType ->
+ let finalType = replaceTyVars mappings startingType
+ in if isArrayTypeOK finalType
+ then Right (xobj {xobjTy = Just finalType})
+ else Left (ArraysCannotContainRefs xobj)
+ Nothing -> pure xobj
+
+-- | Returns false if an array contains a Ref type as a member.
+isArrayTypeOK :: Ty -> Bool
+isArrayTypeOK (StructTy (ConcreteNameTy (SymPath [] "Array")) [RefTy _ _]) =
+ -- An array containing refs!
+ False
+isArrayTypeOK _ = True