@@ -3,16 +3,13 @@ module Type.Constrain.Expression where
3import qualified Data.List as List
3import qualified Data.List as List
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5import qualified Data.Set as Set
5import qualified Data.Set as Set
6−import Control.Arrow (second)
7import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
8import qualified Control.Monad as Monad
7import qualified Control.Monad as Monad
9import Control.Monad.Error
8import Control.Monad.Error
10−import Control.Monad.State
11−import Data.Traversable (traverse)
12import qualified Text.PrettyPrint as PP
9import qualified Text.PrettyPrint as PP
14import SourceSyntax.Location as Loc
11import SourceSyntax.Location as Loc
15−import SourceSyntax.Pattern (Pattern(PVar))
12+import SourceSyntax.Pattern (Pattern(PVar), boundVars)
16import SourceSyntax.Expression
13import SourceSyntax.Expression
17import qualified SourceSyntax.Type as SrcT
14import qualified SourceSyntax.Type as SrcT
18import Type.Type hiding (Descriptor(..))
15import Type.Type hiding (Descriptor(..))
@@ -20,10 +17,8 @@ import Type.Fragment
20import qualified Type.Environment as Env
17import qualified Type.Environment as Env
21import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
22import qualified Type.Constrain.Pattern as Pattern
19import qualified Type.Constrain.Pattern as Pattern
23−import qualified Transform.SortDefinitions as SD
26−constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint
21+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
27constrain env (L span expr) tipe =
22constrain env (L span expr) tipe =
28 let list t = Env.get env Env.types "_List" <| t
23 let list t = Env.get env Env.types "_List" <| t
29 and = L span . CAnd
24 and = L span . CAnd
@@ -145,13 +140,12 @@ constrain env (L span expr) tipe =
145 (schemes, rqs, fqs, header, c2, c1) <-
140 (schemes, rqs, fqs, header, c2, c1) <-
146 Monad.foldM (constrainDef env)
141 Monad.foldM (constrainDef env)
147 ([], [], [], Map.empty, true, true)
142 ([], [], [], Map.empty, true, true)
148− (collapseDefs defs)
143+ (concatMap expandPattern defs)
149 return $ clet schemes
144 return $ clet schemes
150 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
145 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
151 (c1 /\ c))
146 (c1 /\ c))
154−constrainDef env info (pattern, expr, maybeTipe) =
148+constrainDef env info (Definition pattern expr maybeTipe) =
155 let qs = [] -- should come from the def, but I'm not sure what would live there...
149 let qs = [] -- should come from the def, but I'm not sure what would live there...
156 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
150 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info
@@ -188,33 +182,18 @@ constrainDef env info (pattern, expr, maybeTipe) =
188 , c /\ c2
182 , c /\ c2
185+ _ -> error (show pattern)
191−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)
187+expandPattern :: Def -> [Def]
192− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
193−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =
188+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
194 case pattern of
189 case pattern of
195− PVar _ -> [triple]
190+ PVar _ -> [def]
196− _ -> (PVar x, lexpr, maybeType) : map toDef vars
191+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars
198− vars = Set.toList $ SD.boundVars pattern
193+ vars = Set.toList $ boundVars pattern
199 x = "$" ++ concat vars
194 x = "$" ++ concat vars
200− var = L s . Var
195+ mkVar = L s . Var
201− toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)
196+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
203−collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]
204−collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty
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) =
212− Def (PVar name) body ->
213− go output (Map.insert name body defs) typs ds
215− go ((pattern, body, Nothing) : output) defs typs ds
216− TypeAnnotation name typ ->
217− go output defs (Map.insert name typ typs) ds
219try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
198try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
220try span computation = do
199try span computation = do