911d92c · elk · git.iko.soy

git.iko.soy/elk

Improve type hints for values that fall through to JavaScript. Abstract out Guid functions since they are now used in many modules.

commit911d92cd6f6249c81444157f557d69c94d264067 authorevancz <info@elm-lang.org> dateSat 12 May 2012, 00:27 (14 years ago) parent0ca86e4

7 files changed+142−62

compare with master

unifiedsplit

src/Guid.hs+16 src/Initialize.hs+6−1 src/Rename.hs+2−11 src/Types/Constrain.hs+11−14 src/Types/Hints.hs+86−23 src/Types/Types.hs+6−2 src/Types/Unify.hs+15−11

src/Guid.hsnew file+16

@@ -0,0 +1,16 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

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

6+-- Wrapper around State monad.

7+newtype GuidCounter a = GC { runGC :: State Int a }

8+ deriving (Monad)

10+-- Get the next GUID, incrementing the counter.

11+guid :: GuidCounter Int

12+guid = GC $ do n <- get

13+ put (n + 1)

14+ return n

15+

16+run x = evalState (runGC x) 0

src/Initialize.hs+6−1

@@ -13,7 +13,12 @@ import Rename (rename)

1313import Replace

1414import System.IO.Unsafe

1515

16−initialize str = do

16+import Unify

17+

18+initialize str = unify =<< toDefs =<< tokenize str

19+

20+

21+initialize' str = do

1722 expr <- toDefs =<< tokenize str

1823-- let rexpr = rename expr

1924-- let init = simp_loop rexpr

src/Rename.hs+2−11

@@ -6,19 +6,10 @@ import Control.Arrow (first)

66import Control.Monad (ap, liftM, foldM, mapM, Monad)

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

88import Data.Char (isLower)

9−

10−-- Wrapper around State monad.

11−newtype GuidCounter a = GC { runGC :: State Int a }

12− deriving (Monad)

13−

14−-- Get the next GUID, incrementing the counter.

15−guid :: GuidCounter Int

16−guid = GC $ do n <- get

17− put (n + 1)

18− return n

9+import Guid

1910

2011rename :: Expr -> Expr

21−rename expr = evalState (runGC $ rename' id expr) 0

12+rename = run . rename' id

2213

2314rename' :: (String -> String) -> Expr -> GuidCounter Expr

2415rename' env expr =

src/Types/Constrain.hs+11−14

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

22module Constrain where

44import Ast

@@ -6,29 +6,24 @@ import Types

66import qualified Data.Set as Set

77import qualified Data.Map as Map

88import Control.Monad (liftM,mapM)

9−import Control.Monad.State (evalState, State, get, put)

9+import Control.Monad.State (evalState)

10+import Guid

11+import Hints

1012

1113data Constraint = Type :=: Type

1214 | Type :<: Type

1315 | Type :<<: Scheme

1416 deriving (Eq, Ord, Show)

1517

16−-- Wrapper around State monad.

17−newtype GuidCounter a = GC { runGC :: State Int a }

18− deriving (Monad)

19−

20−-- Get the next GUID, incrementing the counter.

21−guid :: GuidCounter Int

22−guid = GC $ do n <- get

23− put (n + 1)

24− return n

25−

2618beta = VarT `liftM` guid

2719unionA = Map.unionWith (++)

2820unionsA = Map.unionsWith (++)

2921

30−constrain expr = Set.toList cs

31− where (as,cs,t) = evalState (runGC $ inference expr) 0

22+constrain expr = run $ do

23+ (as,cs,t) <- inference expr

24+ hs <- hints

25+ let cMap = Map.intersectionWith (\t -> map (:<: t)) (Map.fromList hs) as

26+ return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)

3227

3328inference (Var x) =

3429 do b <- beta

@@ -70,6 +65,8 @@ inference (Data name es) =

7065 do (as,cs,ts) <- unzip3 `liftM` mapM inference es

7166 return ( unionsA as, Set.unions cs, ADT name ts )

7267

68+inference (Binop op e1 e2) = inference (Var op `App` e1 `App` e2)

69+

7370inference other =

7471 case other of

7572 Number _ -> primitive IntT

src/Types/Hints.hs+86−23

@@ -1,29 +1,92 @@

2−module Hints where

2+module Hints (hints) where

4+import Control.Monad (liftM,mapM)

45import Types

6+import Guid

6−elementT = ADT "Element" []

7−n2e2e = LambdaT IntT $ LambdaT elementT elementT

8−

9−str2elem = map (\f -> (f, LambdaT StringT elementT))

10− [ "image", "video", "text", "leftText", "centerText", "rightText" ]

11−

12−textAttrs =

13− [ ("link", LambdaT StringT s2s), ("fontSize", LambdaT IntT s2s) ] ++

14− map (\f -> (f, s2s))

15− ["header", "italic", "bold", "underline"

16− , "overline", "strikeThrough" ]

17− where s2s = LambdaT StringT StringT

18−

19−allHints = str2elem ++ textAttrs ++

20− [ ("flowDown", LambdaT (ADT "List" [elementT]) elementT)

21− , ("flowRight", LambdaT (ADT "List" [elementT]) elementT)

22− , ("opacity", n2e2e)

23− , ("width", n2e2e)

24− , ("height", n2e2e)

25− , ("size", LambdaT IntT n2e2e)

26− , ("centerX", LambdaT elementT elementT)

8+element = ADT "Element" []

9+direction = ADT "Direction" []

10+text = ADT "Text" []

11+listOf t = ADT "List" [t]

12+string = listOf CharT

13+

14+infixr ==>

15+t1 ==> t2 = LambdaT t1 t2

16+

17+infix 8 -:

18+name -: tipe = (,) name tipe

19+

20+hasType t = map (-: t)

21+

22+-------- Text and Elements --------

23+

24+str2elem = hasType (string ==> element) [ "image","video","plainText" ]

25+

26+textToText = ["header", "italic", "bold", "underline"

27+ , "overline", "strikeThrough", "monospace" ]

28+

29+textAttrs = [ "toText" -: string ==> text

30+ , "link" -: string ==> text ==> text

31+ , "height" -: IntT ==> text ==> text

32+ ] ++ hasType (text ==> text) textToText

33+

34+elements = let iee = IntT ==> element ==> element in

35+ [ "flow" -: direction ==> listOf element ==> element

36+ , "opacity" -: iee

37+ , "width" -: iee

38+ , "height" -: iee

39+ , "size" -: IntT ==> iee

40+ , "box" -: iee

2741 ]

2842

29−typeHints = Map.fromList allHints

43+

44+-------- Math and Binops --------

45+

46+iii = IntT ==> IntT ==> IntT

47+xxb x = x ==> x ==> BoolT

48+

49+math =

50+ hasType (IntT ==> iii) ["clamp"] ++

51+ hasType iii ["+", "-", "*", "/","rem","mod","logBase","max","min"] ++

52+ hasType (IntT ==> IntT) ["sin","cos","tan","asin","acos","atan","sqrt","abs"]

53+

54+bool =

55+ [ "not" -: BoolT ==> BoolT ] ++

56+ hasType (xxb BoolT) ["&&","||"] ++

57+ hasType (xxb IntT) ["==","/=","<",">","<=",">="]

58+

59+

60+-------- Polymorphic Functions --------

61+

62+var = VarT `liftM` guid

63+vars n = mapM (const var) [1..n]

64+

65+infix 8 -::

66+name -:: tipe = return $ name -: tipe

67+

68+funcs = sequence

69+ [ do a <- var ; "id" -:: a ==> a

70+ , do [a,b,c] <- vars 3 ; "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)

71+ , do [a,b,c] <- vars 3 ; "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)

72+ , do [a,b] <- vars 2 ; "$" -:: (a ==> b) ==> a ==> b

73+ ]

74+

75+lists = sequence

76+ [ do a <- var ; ":" -:: a ==> listOf a ==> listOf a

77+ , do a <- var ; "++" -:: listOf a ==> listOf a ==> listOf a

78+ , do a <- var ; "head" -:: listOf a ==> a

79+ , do a <- var ; "tail" -:: listOf a ==> listOf a

80+ , do a <- var ; "length" -:: listOf a ==> IntT

81+ , do a <- var ; "filter" -:: (a ==> BoolT) ==> listOf a ==> listOf a

82+ , do a <- var ; "reverse" -:: listOf a ==> listOf a

83+ , do [a,b] <- vars 2 ; "map" -:: (a ==> b) ==> listOf a ==> listOf b

84+ , do [a,b] <- vars 2 ; "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

85+ , do [a,b] <- vars 2 ; "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

86+ ]

87+

88+

89+-------- Everything --------

90+

91+hints = do fs <- funcs ; ls <- lists

92+ return $ fs ++ ls ++ str2elem ++ textAttrs ++ elements ++ math ++ bool

src/Types/Types.hs+6−2

@@ -20,6 +20,8 @@ data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show)

2020

2121data Constructor = Constructor String [Type] deriving (Eq, Show)

2222

23+parens = ("("++) . (++")")

24+

2325instance Show Type where

2426 show t =

2527 case t of

@@ -27,8 +29,10 @@ instance Show Type where

2729 ; StringT -> "String"

2830 ; CharT -> "Char"

2931 ; BoolT -> "Bool"

30− ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

32+ ; LambdaT t1 t2 -> parens $ show t1 ++ " -> " ++ show t2

3133 ; VarT x -> show x

3234 ; AppT name args -> name ++ " " ++ unwords (map show args)

33− ; ADT name constrs -> name

35+ ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"

36+ ; ADT name [] -> name

37+ ; ADT name cs -> parens $ name ++ " " ++ unwords (map show cs)

3438 }

src/Types/Unify.hs+15−11

@@ -5,19 +5,21 @@ import Constrain

55import Control.Arrow (second)

66import Types

8−unify expr = ( constrain expr, solver (constrain expr) [] )

8+unify expr = const expr `fmap` solver (constrain expr) []

1010solver [] subs = Right subs

1111

1212-------- Destruct Type-constructors --------

1313

14−solver ((ADT n1 ts1 :<: ADT n2 ts2) : cs) subs =

15− if n1 /= n2 then Left "unification error" else

16− solver (zipWith (:<:) ts1 ts2 ++ cs) subs

14+solver ((t1@(ADT n1 ts1) :<: t2@(ADT n2 ts2)) : cs) subs =

15+ solver cs subs

16+-- if n1 /= n2 then uniError t1 t2 else

17+-- solver (zipWith (:<:) ts1 ts2 ++ cs) subs

1718

18−solver ((ADT n1 ts1 :=: ADT n2 ts2) : cs) subs =

19− if n1 /= n2 then Left "unification error" else

20− solver (zipWith (:=:) ts1 ts2 ++ cs) subs

19+solver ((t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2)) : cs) subs =

20+ solver cs subs

21+-- if n1 /= n2 then uniError t1 t2 else

22+-- solver (zipWith (:=:) ts1 ts2 ++ cs) subs

2123

2224solver ((LambdaT t1 t2 :<: LambdaT t1' t2') : cs) subs =

2325 solver ([ t1 :<: t1', t2 :<: t2' ] ++ cs) subs

@@ -28,7 +30,7 @@ solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs =

2830-------- subtypes --------

2931

3032solver ((t :<: VarT x) : cs) subs = solver cs' subs

31− where cs' = if all isSubtype cs then cs else (cs ++ [t :<: VarT x])

33+ where cs' = if all isSubtype cs then (t :=: VarT x : cs) else (cs ++ [t :<: VarT x])

3234solver ((t1 :<: t2) : cs) subs = solver ((t1 :=: t2) : cs) subs

3335

3436-------- Type-equality --------

@@ -38,8 +40,7 @@ solver ((VarT x :=: t) : cs) subs =

3840solver ((t :=: VarT x) : cs) subs =

3941 solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs

4042solver ((t1 :=: t2) : cs) subs =

41− if t1 /= t2 then Left $ show t1 ++ " is not equal to " ++ show t2 else

42− solver cs subs

43+ if t1 /= t2 then uniError t1 t2 else solver cs subs

4344

4445

4546cSub k v (t1 :=: t2) = tSub k v t1 :=: tSub k v t2

@@ -50,4 +51,7 @@ tSub k v (LambdaT t1 t2) = LambdaT (tSub k v t1) (tSub k v t2)

5051tSub _ _ t = t

5152

5253isSubtype (_ :<: _) = True

53−isSubtype _ = False

54+isSubtype _ = False

55+

56+uniError t1 t2 =

57+ Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2