703508f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Fix prelude imports and correctly generalize for library types that use `Number`.

703508fevancz14 years ago

compiler/Model/Guid.hs+3−1

compare with master

unifiedsplit

@@ -1,5 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Guid (guid, run, runAt, GuidCounter) where

2+module Guid (guid, set, run, runAt, GuidCounter) where

4import Control.Monad.State (evalState, State, get, put)

@@ -13,5 +13,7 @@ guid = GC $ do n <- get

13 put (n + 1)

14 return n

16+set n = GC (put n)

17+

16run = runAt 0

18run = runAt 0

17runAt n x = evalState (runGC x) n

19runAt n x = evalState (runGC x) n

compiler/Model/Libraries.hs+4−3

@@ -1,4 +1,4 @@

1−module Libraries (libraries, addPrelude, prelude) where

1+module Libraries (libraries, addPrelude) where

3import Ast

4import qualified Data.Map as Map

@@ -11,8 +11,9 @@ addPrelude (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmt

11 where customIms = concatMap addModule prelude

13 addModule (n, method) = case lookup n ims of

14− Nothing -> [(n, method)]

14+ Nothing -> [(n, method)]

15+ Just (As m) -> [(n, method)]

15− Just _ -> []

16+ Just _ -> []

17prelude = text : map (\n -> (n, Hiding [])) modules

18prelude = text : map (\n -> (n, Hiding [])) modules

18 where

19 where

compiler/Types/Constrain.hs+13−14

@@ -12,7 +12,6 @@ import qualified Data.Set as Set

12import Ast

13import Context

14import Guid

15−import qualified Libraries as Libraries

17import Types.Types

16import Types.Types

18import Types.Substitutions

17import Types.Substitutions

@@ -21,12 +20,11 @@ beta = VarT `liftM` guid

21unionA = Map.unionWith (++)

20unionA = Map.unionWith (++)

22unionsA = Map.unionsWith (++)

21unionsA = Map.unionsWith (++)

24−getAliases imports hints = hints ++ concatMap aliasesFrom imports

23+getAliases imports hints = concatMap aliasesFrom imports

25 where aliasesFrom (name,method) =

24 where aliasesFrom (name,method) =

26 let values = concatMap (getValue name) hints

25 let values = concatMap (getValue name) hints

27 in case method of

26 in case method of

28− As alias -> if alias == name then [] else

29− map (\(n,t) -> (alias ++ "." ++ n, t)) values

27+ As alias -> map (\(n,t) -> (alias ++ "." ++ n, t)) values

30 Hiding vs -> filter (\(n,t) -> n `notElem` vs) values

28 Hiding vs -> filter (\(n,t) -> n `notElem` vs) values

31 Importing vs -> filter (\(n,t) -> n `elem` vs) values

29 Importing vs -> filter (\(n,t) -> n `elem` vs) values

32 getValue inModule (name,tipe) =

30 getValue inModule (name,tipe) =

@@ -34,13 +32,15 @@ getAliases imports hints = hints ++ concatMap aliasesFrom imports

34 True -> [ (drop (length inModule + 1) name, tipe) ]

32 True -> [ (drop (length inModule + 1) name, tipe) ]

35 False -> []

33 False -> []

37−findAmbiguous hints hints' assumptions continue =

35+findAmbiguous hints assumptions continue =

38− let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints'

36+ let potentialDups = map head . filter (\g -> length g > 1) . group . sort $

37+ filter (elem '.') hints

39− dups = filter (\k -> Map.member k assumptions) potentialDups

38+ dups = filter (\k -> Map.member k assumptions) potentialDups

40− in case dups of

39+ in case dups of

41− n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++

40+ n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++

41+ "' could refer to " ++

42− "' could refer to " ++ intercalate ", " (filter (isSuffixOf n) hints)

42+ intercalate ", " (filter (isSuffixOf n) hints)

43− _ -> continue

43+ _ -> continue

45mergeSchemes :: [Map.Map String Scheme]

46 -> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)

@@ -61,15 +61,14 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs

62constrain typeHints (Module _ _ imports stmts) = do

63 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

64− hints <- typeHints

64+ aliasHints <- getAliases imports `liftM` typeHints

65 (as', cs', schemes) <- mergeSchemes schemess

66 let constraints = Set.unions (cs':css)

67 as = unionsA (as':ass)

68− aliasHints = getAliases (imports ++ Libraries.prelude) hints

69 allHints = Map.union schemes (Map.fromList aliasHints)

68 allHints = Map.union schemes (Map.fromList aliasHints)

70 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

69 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

71 assumptions <- foldM insert as (Map.keys schemes)

70 assumptions <- foldM insert as (Map.keys schemes)

72− findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do

71+ findAmbiguous (map fst aliasHints) assumptions $ do

73 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs

72 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs

74 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

73 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

75 escapees = Map.keys $ Map.difference assumptions allHints

74 escapees = Map.keys $ Map.difference assumptions allHints

compiler/Types/Hints.hs+8−8

@@ -11,11 +11,11 @@ import Types.Types

12hints :: GuidCounter [(String, Scheme)]

13hints = mapM toScheme values

14− where

14+ where

15− addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)

15+ addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)

16− values = addPrefixes (Map.toList (Map.map Map.toList libraries))

16+ values = addPrefixes (Map.toList (Map.map Map.toList libraries))

17− toScheme (name, tipeString) =

17+ toScheme (name, tipeString) =

18− case iParse (fmap toType typeExpr) "parsing types in docs.json" tipeString of

18+ case iParse (fmap toType typeExpr) "parsing types in docs.json" tipeString of

19− Left err -> error (show err)

19+ Left err -> error (show err)

20− Right tipe -> do scheme <- generalize [] (Forall [] [] tipe)

20+ Right tipe -> do scheme <- generalize [] =<< superize name tipe

21− return (name, scheme)

21+ return (name, scheme)

compiler/Types/Substitutions.hs+59−12

@@ -1,20 +1,22 @@

1−

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2module Types.Substitutions (subst,

3 occurs,

4 freeVars,

5 concretize,

6 rescheme,

7− generalize) where

7+ generalize,

8+ superize) where

9import Ast

10import Ast

10import Context

11import Context

11−import Control.DeepSeq (NFData (..), deepseq)

12+import Control.Monad (liftM, liftM2)

12−import Control.Monad (liftM)

13+import Control.Monad.State (runState, State, get, put)

13import Data.List (foldl')

14import Data.List (foldl')

15+import Data.Maybe (catMaybes)

14import qualified Data.Set as Set

16import qualified Data.Set as Set

15import qualified Data.Map as Map

17import qualified Data.Map as Map

16import Guid

18import Guid

17−import Types.Types

19+import Types.Types as Types

19class Subst a where

21class Subst a where

20 subst :: [(X,Type)] -> a -> a

22 subst :: [(X,Type)] -> a -> a

@@ -51,13 +53,14 @@ class FreeVars a where

51 freeVars :: a -> [X]

53 freeVars :: a -> [X]

53instance FreeVars Type where

55instance FreeVars Type where

54− freeVars (VarT v) = [v]

56+ freeVars t =

57+ case t of

58+ VarT v -> [v]

55− freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2

59+ LambdaT t1 t2 -> freeVars t1 ++ freeVars t2

56− freeVars (ADT _ ts) = concatMap freeVars ts

60+ ADT _ ts -> concatMap freeVars ts

57− freeVars (RecordT fs t) =

58− freeVars (concat $ Map.elems fs) ++ freeVars t

61+ RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t

59− freeVars EmptyRecord = []

62+ EmptyRecord -> []

60− freeVars (Super _ ) = []

63+ Super _ -> []

62instance FreeVars Constraint where

65instance FreeVars Constraint where

63 freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2

66 freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2

@@ -88,3 +91,47 @@ generalize :: [X] -> Scheme -> GuidCounter Scheme

88generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

91generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

89 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

92 where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs

90 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

93 frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

94+

95+newtype Superize a = S { runSuper :: State (Int, Maybe X, Maybe X) a }

96+ deriving (Monad)

97+

98+superize :: String -> Type -> GuidCounter Scheme

99+superize name tipe =

100+ do x <- guid

101+ let (tipe', (m, number, append)) =

102+ runState (runSuper (go tipe)) (x+1, Nothing, Nothing)

103+ mkC super = liftM (\x -> C (Just name) NoSpan (VarT x :<: super))

104+ set m

105+ return (Forall (catMaybes [number,append])

106+ (catMaybes [ mkC Types.number number

107+ , mkC (Types.appendable x) append])

108+ tipe')

109+ where

110+ go :: Type -> Superize Type

111+ go t =

112+ case t of

113+ EmptyRecord -> return t

114+ Super _ -> return t

115+ VarT _ -> return t

116+ LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)

117+ ADT "Number" [] -> liftM VarT number

118+ ADT "Appendable" [] -> liftM VarT append

119+ ADT name ts -> liftM (ADT name) (mapM go ts)

120+ RecordT fs t -> liftM2 RecordT fs' (go t)

121+ where pairs = Map.toList fs

122+ fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs

123+ return (Map.fromList ps)

124+

125+ number :: Superize X

126+ number = S $ do (n, num, append) <- get

127+ case num of

128+ Just x -> return x

129+ Nothing -> do put (n + 1, Just n, append)

130+ return n

131+

132+ append :: Superize X

133+ append = S $ do (n, number, app) <- get

134+ case app of

135+ Just x -> return x

136+ Nothing -> do put (n + 1, number, Just n)

137+ return n

compiler/Types/Types.hs+2−3

@@ -39,9 +39,8 @@ number = Super (Set.fromList [ int, float ])

40char = tipe "Char"

41bool = tipe "Bool"

42−

42+text = tipe "Text"

43string = tipe "String"

44−text = tipe "Text"

46element = tipe "Element"

45element = tipe "Element"

@@ -52,7 +51,7 @@ maybeOf t = ADT "Maybe" [t]

52eitherOf a b = ADT "Either" [a,b]

51eitherOf a b = ADT "Either" [a,b]

53pairOf t = tupleOf [t,t]

52pairOf t = tupleOf [t,t]

54point = pairOf int

53point = pairOf int

55−appendable t = Super (Set.fromList [ string, text, listOf t ])

54+appendable t = Super (Set.fromList [ string, text, listOf (VarT t) ])

56--comparable = Super (Set.fromList [ int, float, char, string, time, date ])

55--comparable = Super (Set.fromList [ int, float, char, string, time, date ])

58infixr ==>

57infixr ==>