c21bebd · tix · git.iko.soy

git.iko.soy/tix

on master help sign in

Added tree tracing

c21bebdiko6 years ago

app/Main.hs+8−4

compare with master

unifiedsplit

@@ -1,6 +1,9 @@

1module Main (main) where

3+import Data.Aeson ((.=))

4+import qualified Data.ByteString.Char8 as BSC

3import qualified Data.Text.IO as T

5import qualified Data.Text.IO as T

6+import qualified Data.Yaml as YAML

4import Lib

7import Lib

5import Nix.Parser

8import Nix.Parser

6import Tix.Typechecker

9import Tix.Typechecker

@@ -11,7 +14,8 @@ main = do

11 case parseNixTextLoc inp of

14 case parseNixTextLoc inp of

12 Failure err -> error $ show err

15 Failure err -> error $ show err

13 Success r -> do

16 Success r -> do

14− let (t, errs, uErrs) = getType r

17+ let (t, errs, uErrs, o) = getType r

15− print errs

18+ BSC.putStrLn . YAML.encode $

16− print uErrs

19+ o <> "errors" .= fmap show errs

20+ <> "unifying_errors" .= fmap show uErrs

17− T.putStrLn $ showNType t

21+ <> "resulting_type" .= showNType t

package.yaml+6

@@ -30,6 +30,12 @@ dependencies:

30 - mono-traversable

31 - acts

32 - groups

33+ - yaml

34+ - aeson

35+ - vector

36+ - unordered-containers

37+ - bytestring

38+ - prettyprinter

33library:

39library:

34 source-dirs: src

40 source-dirs: src

src/Tix/Typechecker.hs+79−8

@@ -5,6 +5,7 @@ module Tix.Typechecker

5 runSeqWriter,

6 getType,

7 showNType,

8+ runNoTreeTracer,

8 )

9 )

9where

10where

@@ -15,13 +16,14 @@ import Control.Monad.Freer.Reader

15import Control.Monad.Freer.State

16import Control.Monad.Freer.State

16import Control.Monad.Freer.Writer

17import Control.Monad.Freer.Writer

17import Data.Act

18import Data.Act

19+import qualified Data.Aeson as A

18import Data.Fix

20import Data.Fix

19import Data.Foldable

21import Data.Foldable

20import Data.Functor

22import Data.Functor

21import Data.Group hiding ((~~))

23import Data.Group hiding ((~~))

24+import qualified Data.HashMap.Strict as HM

22import Data.List.NonEmpty (NonEmpty (..))

25import Data.List.NonEmpty (NonEmpty (..))

23import qualified Data.List.NonEmpty as NE

26import qualified Data.List.NonEmpty as NE

24−import qualified Data.Map.Extra as M

25import Data.Map.Shifted.Strict (ShiftedMap (..))

27import Data.Map.Shifted.Strict (ShiftedMap (..))

26import qualified Data.Map.Shifted.Strict as SM

28import qualified Data.Map.Shifted.Strict as SM

27import Data.Map.Strict (Map)

29import Data.Map.Strict (Map)

@@ -37,9 +39,13 @@ import qualified Data.Set as S

37import Data.Text (Text)

39import Data.Text (Text)

38import qualified Data.Text.Lazy as TL

40import qualified Data.Text.Lazy as TL

39import qualified Data.Text.Lazy.Builder as T

41import qualified Data.Text.Lazy.Builder as T

42+import Data.Text.Prettyprint.Doc as P

43+import Data.Text.Prettyprint.Doc.Render.Text

40import Data.Traversable

44import Data.Traversable

45+import qualified Data.Vector as V

41import Nix.Atoms

46import Nix.Atoms

42import Nix.Expr

47import Nix.Expr

48+import Nix.Pretty

44runConstraintEnv ::

50runConstraintEnv ::

45 Eff (SubstituteEnv : Writer Substitution : Writer Constraint : State (Seq Constraint) : effs) a ->

51 Eff (SubstituteEnv : Writer Substitution : Writer Constraint : State (Seq Constraint) : effs) a ->

@@ -55,9 +61,9 @@ runConstraintEnv =

55 return ()

61 return ()

56 )

62 )

58−getType :: NExprLoc -> (NType, [(SrcSpan, Errors)], [UnifyingError])

64+getType :: NExprLoc -> (NType, [(SrcSpan, Errors)], [UnifyingError], A.Object)

59getType r =

65getType r =

60− let (((((t, unifying), errs), srcs), subs), _) =

66+ let ((((((t, traceTree), unifying), errs), srcs), subs), _) =

61 run

67 run

62 . runConstraintEnv

68 . runConstraintEnv

63 . runState @[(TypeVariable, SrcSpan)] []

69 . runState @[(TypeVariable, SrcSpan)] []

@@ -66,8 +72,9 @@ getType r =

66 . runSeqWriter @[UnifyingError]

72 . runSeqWriter @[UnifyingError]

67 . runReader (M.empty :: VariableMap)

73 . runReader (M.empty :: VariableMap)

68 . runFresh

74 . runFresh

75+ . runTreeTracer

69 $ inferGeneral r

76 $ inferGeneral r

70− in (sub subs t, errs, unifying)

77+ in (sub subs t, errs, unifying, traceTree)

72data SubstituteEnv a where

79data SubstituteEnv a where

73 SubstituteEnv :: Substitution -> SubstituteEnv ()

80 SubstituteEnv :: Substitution -> SubstituteEnv ()

@@ -84,6 +91,9 @@ instance Show TypeVariable where

84data Constraint = !NType :~ !NType

91data Constraint = !NType :~ !NType

85 deriving stock (Eq, Ord, Show)

92 deriving stock (Eq, Ord, Show)

94+instance Pretty Constraint where

95+ pretty (x :~ y) = pretty x <+> "~" <+> pretty y

96+

87data DeBrujin = DeBrujin !Int !Int

97data DeBrujin = DeBrujin !Int !Int

88 deriving stock (Show, Eq, Ord)

98 deriving stock (Show, Eq, Ord)

@@ -240,9 +250,32 @@ instance Free NType where

240 free (NAttrSet attrs) = foldMap free . M.elems $ attrs

250 free (NAttrSet attrs) = foldMap free . M.elems $ attrs

241 free (x :-> y) = free x <> free y

251 free (x :-> y) = free x <> free y

242

252

253+instance Pretty NType where

254+ pretty (NTypeVariable t) = pretty $ prettyTypeVariable t

255+ pretty (NBrujin (DeBrujin i j)) = "⟦" <> pretty i <+> pretty j <> "⟧"

256+ pretty (NAtomic a) = viaShow a

257+ pretty (x :-> y) = sep [pretty x, "->" <+> pretty y]

258+ pretty (List x) = "[" <> align (pretty x) <> "]"

259+ pretty (NAttrSet x) =

260+ sep

261+ [ flatAlt "{ " "{"

262+ <+> align

263+ ( sep . zipWith (<+>) ("" : repeat ";")

264+ . map (\(k, v) -> pretty k <+> "=" <+> align (pretty v))

265+ $ M.toList x

266+ ),

267+ "}"

268+ ]

269+

243newtype Substitution = Substitution {unSubstitution :: Map TypeVariable NType}

270newtype Substitution = Substitution {unSubstitution :: Map TypeVariable NType}

244 deriving newtype (Eq, Ord, Show)

271 deriving newtype (Eq, Ord, Show)

245

272

273+prettyTypeVariable :: TypeVariable -> TL.Text

274+prettyTypeVariable (TypeVariable n) = "⟦" <> (TL.pack . show) n <> "⟧"

275+

276+prettySubstitution :: Substitution -> A.Value

277+prettySubstitution = A.toJSON . M.mapKeysMonotonic prettyTypeVariable . fmap renderPretty . unSubstitution

278+

246-- | Prefers the left

279-- | Prefers the left

247instance Semigroup Substitution where

280instance Semigroup Substitution where

248 x'@(Substitution x) <> (Substitution y) = Substitution (x <> fmap (sub x') y)

281 x'@(Substitution x) <> (Substitution y) = Substitution (x <> fmap (sub x') y)

@@ -375,7 +408,8 @@ type InferEffs =

375 Writer (SrcSpan, Errors),

408 Writer (SrcSpan, Errors),

376 Reader VariableMap,

409 Reader VariableMap,

377 Writer UnifyingError,

410 Writer UnifyingError,

378− SubstituteEnv

411+ SubstituteEnv,

412+ TreeTracer

379 ]

413 ]

380

414

381type InferM x = forall r. Members InferEffs r => Eff r x

415type InferM x = forall r. Members InferEffs r => Eff r x

@@ -580,15 +614,29 @@ inferBinding bindings = do

580-- (_ : (x, _) : _) -> traceM $ x <> " " <> s <> " \t" <> show a

614-- (_ : (x, _) : _) -> traceM $ x <> " " <> s <> " \t" <> show a

581-- _ -> traceM $ s <> " \t" <> show a

615-- _ -> traceM $ s <> " \t" <> show a

582

616

617+renderPretty :: Pretty x => x -> TL.Text

618+renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty

619+

620+showExpr :: Fix NExprLocF -> Text

621+showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation

622+

583inferGeneral :: NExprLoc -> InferM NType

623inferGeneral :: NExprLoc -> InferM NType

584−inferGeneral x = do

624+inferGeneral x = traceSubtree (showExpr x) $ do

625+ (((t, subs), cs), range) <-

585− (((t, subs), cs), range) <- registerTypeVariables . runConstraintEnv $ infer x

626+ traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ infer x

627+ traceValue "received_type" $ renderPretty t

628+ traceValue "received_substitutions" $ prettySubstitution subs

629+ traceValue "received_constraints" $ fmap renderPretty cs

586 s' <- solveWithPriority range cs

630 s' <- solveWithPriority range cs

631+ traceValue "substitutions_after_solving" $ prettySubstitution s'

587 let s = subs <> s'

632 let s = subs <> s'

588 returnedS = Substitution . M.filterWithKey (\k _ -> k `R.notMember` range) . unSubstitution $ s

633 returnedS = Substitution . M.filterWithKey (\k _ -> k `R.notMember` range) . unSubstitution $ s

634+ traceValue "returned_substitutions" $ prettySubstitution returnedS

589 -- Filter for optimization purposes

635 -- Filter for optimization purposes

590 subEnv returnedS

636 subEnv returnedS

591− return . close range $ sub s t

637+ let retT = close range $ sub s t

638+ traceValue "returned_type" $ renderPretty retT

639+ return retT

592

640

593expectAttrSet :: Members '[Reader SrcSpan, Writer (SrcSpan, Errors)] r => NType -> Eff r VariableMap

641expectAttrSet :: Members '[Reader SrcSpan, Writer (SrcSpan, Errors)] r => NType -> Eff r VariableMap

594expectAttrSet (NAttrSet x) = return x

642expectAttrSet (NAttrSet x) = return x

@@ -676,3 +724,26 @@ lookupAttrSet path = go (NE.toList path)

676 expectAttrSet x <&> M.lookup p >>= \case

724 expectAttrSet x <&> M.lookup p >>= \case

677 Nothing -> NTypeVariable <$> throwSrcTV (KeyNotPresent p)

725 Nothing -> NTypeVariable <$> throwSrcTV (KeyNotPresent p)

678 Just t -> go ps t

726 Just t -> go ps t

727+

728+data TreeTracer a where

729+ TraceTree :: A.Object -> TreeTracer ()

730+

731+traceValue :: (A.ToJSON v, Member TreeTracer eff) => Text -> v -> Eff eff ()

732+traceValue k v = send $ TraceTree $ k A..= v

733+

734+traceSubtree :: Member TreeTracer eff => Text -> Eff eff a -> Eff eff a

735+traceSubtree k = interpose (\(TraceTree o) -> send $ TraceTree (k A..= o))

736+

737+runTreeTracer :: Eff (TreeTracer ': eff) a -> Eff eff (a, A.Object)

738+runTreeTracer = handleRelayS HM.empty (\s x -> pure (x, s)) $ \s (TraceTree o) k ->

739+ k (HM.unionWith unionToList s o) ()

740+ where

741+ unionToList :: A.Value -> A.Value -> A.Value

742+ unionToList (A.Array x) (A.Array y) = A.Array $ x <> y

743+ unionToList (A.Array x) y = A.Array $ V.snoc x y

744+ unionToList x (A.Array y) = A.Array $ V.cons x y

745+ unionToList (A.Object x) (A.Object y) = A.Object $ HM.unionWith unionToList x y

746+ unionToList x y = A.Array $ V.fromList [x, y]

747+

748+runNoTreeTracer :: Eff (TreeTracer ': eff) a -> Eff eff a

749+runNoTreeTracer = interpret (\(TraceTree _) -> return ())

stack.yaml+1−1

@@ -17,7 +17,7 @@

17#

18# resolver: ./custom-snapshot.yaml

19# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver: lts-17.0

20+resolver: lts-17.1

22# User packages to be built.

23# Various formats can be used as shown in the example below.