911d92c · elk · git.iko.soy

src/Guid.hsnew file+16

compare with master

unifiedsplit

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

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

3+

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

5+

6+-- Wrapper around State monad.

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

8+ deriving (Monad)

9+

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)

13import Replace

14import System.IO.Unsafe

15

16+import Unify

17+

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

19+

20+

16−initialize str = do

21+initialize' str = do

17 expr <- toDefs =<< tokenize str

22 expr <- toDefs =<< tokenize str

18-- let rexpr = rename expr

23-- let rexpr = rename expr

19-- let init = simp_loop rexpr

24-- let init = simp_loop rexpr

src/Rename.hs+2−11

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

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

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

8import Data.Char (isLower)

9−

9+import Guid

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

19

10

20rename :: Expr -> Expr

11rename :: Expr -> Expr

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

12+rename = run . rename' id

22

13

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

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

24rename' env expr =

15rename' env expr =

src/Types/Constrain.hs+11−14

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1+

2module Constrain where

3

4import Ast

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

6import qualified Data.Set as Set

7import qualified Data.Map as Map

8import 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

10

12

11data Constraint = Type :=: Type

13data Constraint = Type :=: Type

12 | Type :<: Type

14 | Type :<: Type

13 | Type :<<: Scheme

15 | Type :<<: Scheme

14 deriving (Eq, Ord, Show)

16 deriving (Eq, Ord, Show)

15

17

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−

26beta = VarT `liftM` guid

18beta = VarT `liftM` guid

27unionA = Map.unionWith (++)

19unionA = Map.unionWith (++)

28unionsA = Map.unionsWith (++)

20unionsA = Map.unionsWith (++)

29

21

30−constrain expr = Set.toList cs

22+constrain expr = run $ do

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

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)

32

27

33inference (Var x) =

28inference (Var x) =

34 do b <- beta

29 do b <- beta

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

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

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

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

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

72

67

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

69+

73inference other =

70inference other =

74 case other of

71 case other of

75 Number _ -> primitive IntT

72 Number _ -> primitive IntT

src/Types/Hints.hs+86−23

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

1

2−module Hints where

2+module Hints (hints) where

3

4+import Control.Monad (liftM,mapM)

4import Types

5import Types

6+import Guid

5

7

6−elementT = ADT "Element" []

8+element = ADT "Element" []

7−n2e2e = LambdaT IntT $ LambdaT elementT elementT

9+direction = ADT "Direction" []

8−

10+text = ADT "Text" []

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

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

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

12+string = listOf CharT

11−

13+

12−textAttrs =

14+infixr ==>

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

15+t1 ==> t2 = LambdaT t1 t2

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

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+

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

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

16− , "overline", "strikeThrough" ]

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

17− where s2s = LambdaT StringT StringT

28+

18−

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

19−allHints = str2elem ++ textAttrs ++

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

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

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

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

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

33+

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

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

22− , ("opacity", n2e2e)

36+ , "opacity" -: iee

23− , ("width", n2e2e)

37+ , "width" -: iee

24− , ("height", n2e2e)

38+ , "height" -: iee

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

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

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

40+ , "box" -: iee

27 ]

41 ]

28

42

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)

20

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

22

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

24+

23instance Show Type where

25instance Show Type where

24 show t =

26 show t =

25 case t of

27 case t of

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

27 ; StringT -> "String"

29 ; StringT -> "String"

28 ; CharT -> "Char"

30 ; CharT -> "Char"

29 ; BoolT -> "Bool"

31 ; BoolT -> "Bool"

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

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

31 ; VarT x -> show x

33 ; VarT x -> show x

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

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

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

33− ; ADT name constrs -> name

36+ ; ADT name [] -> name

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

34 }

38 }

src/Types/Unify.hs+15−11

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

5import Control.Arrow (second)

6import Types

7

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

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

9

10solver [] subs = Right subs

11

12-------- Destruct Type-constructors --------

13

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

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

15+ solver cs subs

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

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

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

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

17

18

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

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

20+ solver cs subs

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

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

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

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

21

23

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

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

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

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

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

28-------- subtypes --------

30-------- subtypes --------

29

31

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

32solver ((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])

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

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

33

35

34-------- Type-equality --------

36-------- Type-equality --------

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

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

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

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

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

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

42solver ((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

43

44

45

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

46cSub 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)

50tSub _ _ t = t

51tSub _ _ t = t

51

52

52isSubtype (_ :<: _) = True

53isSubtype (_ :<: _) = True

53−isSubtype _ = False

54+isSubtype _ = False

55+

56+uniError t1 t2 =

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