@@ -3,16 +3,13 @@ module Type.Constrain.Expression where
33import qualified Data.List as List
44import qualified Data.Map as Map
55import qualified Data.Set as Set
6−import Control.Arrow (second)
76import Control.Applicative ((<$>),(<*>))
87import qualified Control.Monad as Monad
98import Control.Monad.Error
10−import Control.Monad.State
11−import Data.Traversable (traverse)
129import qualified Text.PrettyPrint as PP
1310
1411import SourceSyntax.Location as Loc
15−import SourceSyntax.Pattern (Pattern(PVar))
12+import SourceSyntax.Pattern (Pattern(PVar), boundVars)
1613import SourceSyntax.Expression
1714import qualified SourceSyntax.Type as SrcT
1815import Type.Type hiding (Descriptor(..))
@@ -20,10 +17,8 @@ import Type.Fragment
2017import qualified Type.Environment as Env
2118import qualified Type.Constrain.Literal as Literal
2219import qualified Type.Constrain.Pattern as Pattern
23−import qualified Transform.SortDefinitions as SD
2420
25−
26−constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint
21+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
2722constrain env (L span expr) tipe =
2823 let list t = Env.get env Env.types "_List" <| t
2924 and = L span . CAnd
@@ -145,13 +140,12 @@ constrain env (L span expr) tipe =
145140 (schemes, rqs, fqs, header, c2, c1) <-
146141 Monad.foldM (constrainDef env)
147142 ([], [], [], Map.empty, true, true)
148− (collapseDefs defs)
143+ (concatMap expandPattern defs)
149144 return $ clet schemes
150145 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
151146 (c1 /\ c))
152147
153−
154−constrainDef env info (pattern, expr, maybeTipe) =
148+constrainDef env info (Definition pattern expr maybeTipe) =
155149 let qs = [] -- should come from the def, but I'm not sure what would live there...
156150 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
157151 in
@@ -188,33 +182,18 @@ constrainDef env info (pattern, expr, maybeTipe) =
188182 , c /\ c2
189183 , c1 )
190184
191−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
192− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
193−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
185+ _ -> error (show pattern)
186+
187+expandPattern :: Def -> [Def]
188+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
194189 case pattern of
195− PVar _ -> [triple]
196− _ -> (PVar x, lexpr, maybeType) : map toDef vars
190+ PVar _ -> [def]
191+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars
197192 where
198− vars = Set.toList $ SD.boundVars pattern
193+ vars = Set.toList $ boundVars pattern
199194 x = "$" ++ concat vars
200− var = L s . Var
201− toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)
202−
203−collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
204−collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
205− where
206− go output defs typs [] =
207− output ++ concatMap Map.elems [
208− Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,
209− Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]
210− go output defs typs (d:ds) =
211− case d of
212− Def (PVar name) body ->
213− go output (Map.insert name body defs) typs ds
214− Def pattern body ->
215− go ((pattern, body, Nothing) : output) defs typs ds
216− TypeAnnotation name typ ->
217− go output defs (Map.insert name typ typs) ds
195+ mkVar = L s . Var
196+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
218197
219198try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
220199try span computation = do