@@ -9,8 +9,12 @@ module Tix.Typechecker
12+import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM
13+import qualified Algebra.Graph.Class as G
14+import qualified Algebra.Graph.NonEmpty.AdjacencyMap as AM
12import Control.Lens hiding (Empty, List, cons, equality, set, set')
15import Control.Lens hiding (Empty, List, cons, equality, set, set')
13import Control.Monad
16import Control.Monad
17+import qualified Control.Monad.Free as F
14import Control.Monad.Freer
18import Control.Monad.Freer
15import Control.Monad.Freer.Fresh
19import Control.Monad.Freer.Fresh
16import Control.Monad.Freer.Internal (handleRelayS)
20import Control.Monad.Freer.Internal (handleRelayS)
@@ -25,6 +29,7 @@ import Data.Foldable
25import Data.Functor.Contravariant
29import Data.Functor.Contravariant
26import Data.Group hiding ((~~))
30import Data.Group hiding ((~~))
27import Data.List.NonEmpty (NonEmpty (..))
31import Data.List.NonEmpty (NonEmpty (..))
32+import qualified Data.List.NonEmpty as NE
28import qualified Data.Map.MultiKey.Strict as MKM
33import qualified Data.Map.MultiKey.Strict as MKM
29import Data.Map.Shifted.Strict (ShiftedMap (..))
34import Data.Map.Shifted.Strict (ShiftedMap (..))
30import qualified Data.Map.Shifted.Strict as SM
35import qualified Data.Map.Shifted.Strict as SM
@@ -35,7 +40,7 @@ import Data.MonoTraversable
35import Data.Monoid
40import Data.Monoid
36import qualified Data.RangeSet.Map as RS
41import qualified Data.RangeSet.Map as RS
37import Data.Sequence (Seq (..))
42import Data.Sequence (Seq (..))
38−import Data.Sequences
43+import Data.Sequences hiding (catMaybes)
39import Data.Set (Set)
44import Data.Set (Set)
40import qualified Data.Set as S
45import qualified Data.Set as S
41import Data.Text (Text)
46import Data.Text (Text)
@@ -48,6 +53,7 @@ import Nix.Atoms
48import Nix.Expr
53import Nix.Expr
49import Nix.Pretty
54import Nix.Pretty
50import Tix.Types
55import Tix.Types
52getType :: NExprLoc -> (Scheme, [(SrcSpan, Errors)], [InferError], [UnifyingError], [PredicateError], A.Object)
58getType :: NExprLoc -> (Scheme, [(SrcSpan, Errors)], [InferError], [UnifyingError], [PredicateError], A.Object)
53getType r =
59getType r =
@@ -210,6 +216,7 @@ unifySchemes :: Predicate TypeVariable -> [(Scheme, Scheme)] -> UnifyM Substitut
210unifySchemes _ [] = pure mempty
216unifySchemes _ [] = pure mempty
211unifySchemes f ((x, y) : rest) = do
217unifySchemes f ((x, y) : rest) = do
212 s <- unifyScheme f x y
218 s <- unifyScheme f x y
219+ -- TODO: This should probably be (s <>)
213 sub s <$> unifySchemes f (sub s rest)
220 sub s <$> unifySchemes f (sub s rest)
215unifyScheme :: Predicate TypeVariable -> Scheme -> Scheme -> UnifyM Substitution
222unifyScheme :: Predicate TypeVariable -> Scheme -> Scheme -> UnifyM Substitution
@@ -266,7 +273,7 @@ data PredicateError
266 deriving stock (Eq, Show)
273 deriving stock (Eq, Show)
268data InferError
275data InferError
269− = ConflictingBindingDefinitions NormalizedBinding' NormalizedBinding'
276+ = ConflictingBindingDefinitions (NormalizedBinding' NExprLoc) (NormalizedBinding' NExprLoc)
270 deriving stock (Show)
277 deriving stock (Show)
272type UnifyM x = forall r. Members '[Writer UnifyingError] r => Eff r x
279type UnifyM x = forall r. Members '[Writer UnifyingError] r => Eff r x
@@ -438,6 +445,10 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
438 defT ~~ resT
445 defT ~~ resT
439 return resT
446 return resT
440 NSet NNonRecursive xs -> NAttrSet <$> inferBinding xs
447 NSet NNonRecursive xs -> NAttrSet <$> inferBinding xs
448+ NSet NRecursive xs -> NAttrSet <$> inferRecBinding xs
449+ NLet bindings body -> do
450+ bindingsT <- inferRecBinding bindings
451+ withBindings bindingsT $ infer body
441 NHasAttr attrSet path -> do
452 NHasAttr attrSet path -> do
442 setT <- infer attrSet
453 setT <- infer attrSet
443 -- this should infer optional type
454 -- this should infer optional type
@@ -460,9 +471,6 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
460 return (setT, maybe M.empty (`M.singleton` scheme setT) binding <> setBindings)
471 return (setT, maybe M.empty (`M.singleton` scheme setT) binding <> setBindings)
461 bodyT <- withBindings varMap $ infer body
472 bodyT <- withBindings varMap $ infer body
462 return $ paramT :-> bodyT
473 return $ paramT :-> bodyT
463− NLet bindings body -> do
464− bindingsT <- inferBinding bindings
465− withBindings bindingsT $ infer body
466 NIf cond t f -> do
474 NIf cond t f -> do
467 condT <- infer cond
475 condT <- infer cond
468 condT ~~ NAtomic Bool
476 condT ~~ NAtomic Bool
@@ -519,12 +527,11 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
519 lhst ~~ NAtomic Bool
527 lhst ~~ NAtomic Bool
520 return $ NAtomic Bool
528 return $ NAtomic Bool
522−data NormalizedBinding' = NBType !NExprLoc | NBAttrSet !NormalizedBinding
530+type NormalizedBinding' = F.Free (Map VarName)
523− deriving stock (Show)
525−type NormalizedBinding = Map VarName NormalizedBinding'
532+type NormalizedBinding x = Map VarName (NormalizedBinding' x)
527−normalizeBindings :: Member (Writer InferError) eff => [Binding NExprLoc] -> Eff eff NormalizedBinding
534+normalizeBindings :: Member (Writer InferError) eff => [Binding NExprLoc] -> Eff eff (NormalizedBinding NExprLoc)
528normalizeBindings bindings = case bindings' of
535normalizeBindings bindings = case bindings' of
529 [] -> return M.empty
536 [] -> return M.empty
530 (x : xs) ->
537 (x : xs) ->
@@ -532,18 +539,18 @@ normalizeBindings bindings = case bindings' of
532 -- This is really sub-optimal
539 -- This is really sub-optimal
533 foldl (\u -> M.unionWith (\i j -> i >>= \i' -> j >>= mergeBindings i') u . fmap pure) (fmap pure x) xs
540 foldl (\u -> M.unionWith (\i j -> i >>= \i' -> j >>= mergeBindings i') u . fmap pure) (fmap pure x) xs
535− mergeBindings (NBAttrSet lhs) (NBAttrSet rhs) =
542+ mergeBindings (F.Free lhs) (F.Free rhs) =
536− fmap NBAttrSet . sequence $
543+ fmap F.Free . sequence $
537 -- This is really sub-optimal
544 -- This is really sub-optimal
538 M.unionWith (\x y -> x >>= \x' -> y >>= mergeBindings x') (pure <$> lhs) (pure <$> rhs)
545 M.unionWith (\x y -> x >>= \x' -> y >>= mergeBindings x') (pure <$> lhs) (pure <$> rhs)
539 mergeBindings x y = do
546 mergeBindings x y = do
540 tell $ ConflictingBindingDefinitions x y
547 tell $ ConflictingBindingDefinitions x y
542− fromName :: NonEmpty VarName -> NExprLoc -> NormalizedBinding
549+ fromName :: NonEmpty VarName -> x -> NormalizedBinding x
543− fromName (n :| ns) x = M.singleton n $ foldr (\u t -> NBAttrSet $ M.singleton u t) (NBType x) ns
550+ fromName (n :| ns) x = M.singleton n $ foldr (\u t -> F.Free $ M.singleton u t) (F.Pure x) ns
544 bindings' =
551 bindings' =
545 bindings >>= \case
552 bindings >>= \case
546− (NamedVar path r src) ->
553+ (NamedVar path r _src) ->
547 case getPath path of
554 case getPath path of
548 Nothing -> [] -- TODO: This should be an error (?)
555 Nothing -> [] -- TODO: This should be an error (?)
549 Just name -> pure $ fromName name r
556 Just name -> pure $ fromName name r
@@ -554,53 +561,188 @@ normalizeBindings bindings = case bindings' of
554 Just set -> \v -> Fix $ Compose $ Ann (SrcSpan src src) $ NSelect set (pure $ StaticKey v) Nothing
561 Just set -> \v -> Fix $ Compose $ Ann (SrcSpan src src) $ NSelect set (pure $ StaticKey v) Nothing
555 in (\v -> fromName (pure v) (f v)) <$> names
562 in (\v -> fromName (pure v) (f v)) <$> names
557−inferNormalizedBindings' :: NormalizedBinding' -> InferM' Scheme
564+inferNormalizedBindings :: NormalizedBinding NExprLoc -> InferM' (Map VarName Scheme)
558−inferNormalizedBindings' (NBType expr) = inferGeneral expr
559−inferNormalizedBindings' (NBAttrSet m) = scheme . NAttrSet <$> inferNormalizedBindings' `traverse` m
561−inferNormalizedBindings :: NormalizedBinding -> InferM' (Map VarName Scheme)
562inferNormalizedBindings = traverse inferNormalizedBindings'
565inferNormalizedBindings = traverse inferNormalizedBindings'
567+ inferNormalizedBindings' :: NormalizedBinding' NExprLoc -> InferM' Scheme
568+ inferNormalizedBindings' (F.Pure expr) = inferGeneral expr
569+ inferNormalizedBindings' (F.Free m) = scheme . NAttrSet <$> inferNormalizedBindings' `traverse` m
571+inferNormalizedBindingsRecursive :: NormalizedBinding NExprLoc -> InferM' (Map VarName Scheme)
572+inferNormalizedBindingsRecursive n = do
573+ let components = case AM.topSort . AM.scc $ bindingGraph n of
574+ Left x -> [foldMap AM.vertexSet x]
575+ Right x -> AM.vertexSet <$> P.reverse x
576+ fmap toScheme <$> inferComponents n components
578+ toScheme :: NormalizedBinding' Scheme -> Scheme
579+ toScheme (F.Pure t) = t
580+ toScheme (F.Free m) = scheme $ NAttrSet $ fmap toScheme m
582+inferComponents :: NormalizedBinding NExprLoc -> [Set (NonEmpty VarName)] -> InferM' (NormalizedBinding Scheme)
583+inferComponents _ [] = pure M.empty
584+inferComponents n ((S.toList -> paths) : otherComponents) = do
585+ let bindings = catMaybes $ paths <&> \path -> (path,) <$> lookupExpr path n
586+ (types, p, preds, s) <-
587+ traceSubtree (showExpr . bindingsToNExpr $ bindings)
588+ . inferGeneral' (NAttrSet . fmap toScheme)
590+ tvsExprs <- for bindings (\(a, b) -> (a,b,) . NTypeVariable <$> freshSrc)
592+ foldl' (M.unionWith mergeBindings) M.empty $
593+ fmap (\(a, b, c) -> normalize a (b, c)) tvsExprs
594+ tvs = toScheme . fmap snd <$> tvsExprs'
599+ tvsExprs' & traverse . traverse . _1 %%~ infer
600+ for_ tvsTypes $ traverse (uncurry (~~))
601+ return $ fmap fst <$> tvsTypes
602+ -- TODO: There should probably be some smarter predicate filtering
603+ schemes <- types & traverse . traverse %%~ (\t -> solveAndClose p $ sub s $ preds :=> t)
604+ fmap (M.unionWith mergeBindings schemes) . withBindings (toScheme' <$> schemes) $
605+ inferComponents n otherComponents
607+ bindingToNExpr :: NonEmpty VarName -> NExprLoc -> Binding NExpr
608+ bindingToNExpr name expr = NamedVar (StaticKey <$> name) (stripAnnotation expr) nullPos
610+ bindingsToNExpr :: [(NonEmpty VarName, NExprLoc)] -> NExpr
611+ bindingsToNExpr bs = Fix $ NSet NNonRecursive $ fmap (uncurry bindingToNExpr) bs
613+ normalize :: NonEmpty VarName -> x -> NormalizedBinding x
614+ normalize (NESingle x) t = M.singleton x (F.Pure t)
615+ normalize (x :|| xs) t = M.singleton x (F.Free $ normalize xs t)
617+ mergeBindings :: NormalizedBinding' x -> NormalizedBinding' x -> NormalizedBinding' x
618+ mergeBindings (F.Free lhs) (F.Free rhs) = F.Free $ M.unionWith mergeBindings lhs rhs
619+ -- This should have been taken care of when constructing the structures.
620+ mergeBindings _ _ = error "not possible"
622+ toScheme :: NormalizedBinding' NType -> Scheme
623+ toScheme (F.Pure t) = scheme t
624+ toScheme (F.Free m) = scheme $ NAttrSet $ fmap toScheme m
626+ toScheme' :: NormalizedBinding' Scheme -> Scheme
627+ toScheme' (F.Pure t) = t
628+ toScheme' (F.Free m) = scheme $ NAttrSet $ fmap toScheme' m
630+ -- Returns Just only if it is the tip.
631+ -- This is what we want because non-tip elements are also part of the call graph.
632+ lookupExpr :: NonEmpty VarName -> NormalizedBinding x -> Maybe x
633+ lookupExpr (NESingle x) m =
634+ M.lookup x m >>= \case
637+ lookupExpr (x :|| xs) m =
638+ M.lookup x m >>= \case
640+ F.Free a -> lookupExpr xs a
642+bindingGraph :: forall g. (G.Graph g, G.Vertex g ~ NonEmpty VarName) => NormalizedBinding NExprLoc -> g
643+bindingGraph n = G.overlays . fmap (\(k, v) -> getGraph (pure k) v) . M.toList $ n
645+ getGraph :: NonEmpty VarName -> NormalizedBinding' NExprLoc -> g
646+ getGraph p (F.Pure e) = G.star p (P.filter (elemBindingSet n) $ getReferences e)
647+ getGraph p (F.Free m) = G.star p (fmap fst attrs) `G.overlay` G.overlays (fmap (uncurry getGraph) attrs)
649+ attrs = (\(k, v) -> (p <> pure k, v)) <$> M.toList m
650+ elemBindingSet :: NormalizedBinding x -> NonEmpty VarName -> Bool
651+ elemBindingSet m = elemBindingSet' m . NE.toList
652+ elemBindingSet' :: NormalizedBinding x -> [VarName] -> Bool
653+ elemBindingSet' _ [] = True
654+ elemBindingSet' m (x : xs) = case M.lookup x m of
656+ Just (F.Free next) -> elemBindingSet' next xs
657+ Just (F.Pure _) -> case xs of
661+getReferences :: NExprLoc -> [NonEmpty VarName]
662+getReferences expr@(Fix (Compose (Ann _ x))) = case x of
664+ NLiteralPath _ -> []
667+ NSym var -> [pure var]
668+ NList xs -> foldMap getReferences xs
669+ NUnary _ a -> getReferences a
670+ NBinary _ a b -> getReferences a <> getReferences b
671+ NSelect {} -> case processSelect expr of
672+ (Nothing, other) -> other
673+ (Just p, other) -> pure p <> other
674+ NSet _ xs -> foldMap getReferences $ xs >>= toList -- This is not strictly correct
675+ NHasAttr a _ -> getReferences a
676+ NAbs _ a -> getReferences a -- This is not strictly correct
677+ NLet a b -> foldMap getReferences (a >>= toList) <> getReferences b -- This is not strictly correct
678+ NIf a b c -> getReferences a <> getReferences b <> getReferences c -- This is not strictly correct
679+ NWith a b -> getReferences a <> getReferences b -- This is not strictly correct
680+ NAssert a b -> getReferences a <> getReferences b
683+ processSelect :: NExprLoc -> (Maybe (NonEmpty VarName), [NonEmpty VarName])
684+ processSelect u@(Fix (Compose (Ann _ y))) = case y of
685+ NSym var -> (Just $ pure var, [])
686+ NSelect l h m -> fmap
687+ (join (maybeToList (getReferences <$> m)) <>)
689+ Nothing -> (Nothing, getReferences l)
690+ Just p -> case processSelect l of
691+ (Just path, other) -> (Just $ path <> p, other)
692+ (Nothing, other) -> (Nothing, other)
693+ _ -> (Nothing, getReferences u)
564inferBinding :: [Binding NExprLoc] -> InferM' (Map VarName Scheme)
695inferBinding :: [Binding NExprLoc] -> InferM' (Map VarName Scheme)
565inferBinding = normalizeBindings >=> inferNormalizedBindings
696inferBinding = normalizeBindings >=> inferNormalizedBindings
698+inferRecBinding :: [Binding NExprLoc] -> InferM' (Map VarName Scheme)
699+inferRecBinding = normalizeBindings >=> inferNormalizedBindingsRecursive
567renderPretty :: Pretty x => x -> TL.Text
701renderPretty :: Pretty x => x -> TL.Text
568renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty
702renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty
570−showExpr :: Fix NExprLocF -> Text
704+showExpr :: NExpr -> Text
571−showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation
705+showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix
573inferGeneral :: NExprLoc -> InferM Scheme
707inferGeneral :: NExprLoc -> InferM Scheme
574−inferGeneral x@(Fix (Compose (Ann src _))) = runReader src $
708+inferGeneral x@(Fix (Compose (Ann src _))) = runReader src . traceSubtree (showExpr . stripAnnotation $ x) $ do
575− traceSubtree (showExpr x) $ do
709+ (t, p, keep, s) <- inferGeneral' id $ infer x
710+ solveAndClose p $ sub s $ keep :=> t
713+ (Members InferEffs r, Pretty y) =>
715+ Eff (SubstituteEnv : Writer Substitution : Writer Constraint : State (Seq Constraint) : r) x ->
716+ Eff r (x, Predicate TypeVariable, [Pred], Substitution)
717+inferGeneral' toPretty f = do
576− (((t, subs), cs), range) <-
718+ (((x, subs), cs), range) <-
577− traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ infer x
719+ traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ f
578− traceSubtree "received" $ do
720+ traceSubtree "received" $ do
579− traceValue "type" $ renderPretty t
721+ traceValue "type" $ renderPretty $ toPretty x
580− traceValue "substitutions" $ prettySubstitution subs
722+ traceValue "substitutions" $ prettySubstitution subs
581− traceValue "constraints" $ fmap renderPretty cs
723+ traceValue "constraints" $ fmap renderPretty cs
582− traceValue "range" $ T.pack . show $ range
724+ traceValue "range" $ T.pack . show $ range
583− get @(MKM.Map Pred) >>= traceValue "preds" . showPreds
725+ get @(MKM.Map Pred) >>= traceValue "preds" . showPreds
584− s' <- solveWithPriority (Predicate (`RS.member` range)) cs
726+ s' <- solveWithPriority (Predicate (`RS.member` range)) cs
585− traceValue "substitutions_after_solving" $ prettySubstitution s'
727+ traceValue "substitutions_after_solving" $ prettySubstitution s'
586− let s = subs <> s'
728+ let s = subs <> s'
587− returnedS = Substitution . M.filterWithKey (\k _ -> k `RS.notMember` range) . unSubstitution $ s
729+ returnedS = Substitution . M.filterWithKey (\k _ -> k `RS.notMember` range) . unSubstitution $ s
588− traceSubtree "returned" $ do
730+ traceSubtree "returned" $ do
589− traceValue "substitutions" $ prettySubstitution returnedS
731+ traceValue "substitutions" $ prettySubstitution returnedS
590− -- Filter for optimization purposes
732+ -- Filter for optimization purposes
591− subEnv returnedS
733+ subEnv returnedS
592− preds <- get @(MKM.Map Pred)
734+ preds <- get @(MKM.Map Pred)
593− traceValue "subbed_preds" $ showPreds preds
735+ traceValue "subbed_preds" $ showPreds preds
594− let p = Predicate (`RS.member` range) <> Predicate (`S.notMember` free returnedS)
736+ let p = Predicate (`RS.member` range) <> Predicate (`S.notMember` free returnedS)
595− (MKM.toList -> keep, toss) = MKM.partition (getPredicate p) preds
737+ (keep', toss) = MKM.partition (getPredicate p) preds
738+ keep = MKM.toList keep'
596− -- At this point the only predicates only contain type variables that are only used
739+ -- At this point the only predicates only contain type variables that are only used
597− -- in the expression. This means that all of the generated constraints and
740+ -- in the expression. This means that all of the generated constraints and
598− -- substitutions can be safely restricted to this expression.
741+ -- substitutions can be safely restricted to this expression.
599− retT <- solveAndClose p $ sub s $ keep :=> t
742+ traceValue "preds" $ showPreds toss
600− traceValue "preds" $ showPreds toss
743+ traceValue "keep_preds" $ showPreds keep'
601− put toss
744+ put toss
602− traceValue "type" $ renderPretty retT
603− return retT
745+ return (x, p, keep, s)
605 showPreds :: MKM.Map Pred -> Map String String
747 showPreds :: MKM.Map Pred -> Map String String
606 showPreds = M.mapKeys show . fmap show . MKM.toMap
748 showPreds = M.mapKeys show . fmap show . MKM.toMap
@@ -746,13 +888,33 @@ lookupAttrSet ::
747 AttrSetPath ->
889 AttrSetPath ->
748 Eff r (NType, TypeVariable)
890 Eff r (NType, TypeVariable)
749−lookupAttrSet (p :| []) = do
891+lookupAttrSet (NESingle p) = do
750 set <- NTypeVariable <$> freshSrc
892 set <- NTypeVariable <$> freshSrc
751 var <- freshSrc
893 var <- freshSrc
752 tell (HasField set (p, scheme . NTypeVariable $ var))
894 tell (HasField set (p, scheme . NTypeVariable $ var))
753 return (set, var)
895 return (set, var)
754−lookupAttrSet (p :| (pp : ps)) = do
896+lookupAttrSet (p :|| ps) = do
755 set <- NTypeVariable <$> freshSrc
897 set <- NTypeVariable <$> freshSrc
756− (innerSet, var) <- lookupAttrSet (pp :| ps)
898+ (innerSet, var) <- lookupAttrSet ps
757 tell $ HasField set (p, scheme innerSet)
899 tell $ HasField set (p, scheme innerSet)
758 return (set, var)
900 return (set, var)
904+pattern (:||) :: x -> NonEmpty x -> NonEmpty x
905+pattern (:||) x xs <-
907+ (a :| (aa : aaa)) -> Just (a, aa :| aaa)
912+ x :|| xs = NE.cons x xs
914+pattern NESingle :: x -> NonEmpty x
915+pattern NESingle x <-
918+ NESingle x = x :| []
920+{-# COMPLETE (:||), NESingle #-}