f76a22e · elk · git.iko.soy

src/Initialize.hs+7−3

compare with master

unifiedsplit

@@ -11,19 +11,23 @@ import Lexer

11import Parser (toExpr,toDefs)

12import Rename (rename)

13import Replace

14−import System.IO.Unsafe

15

14

16import Unify

15import Unify

16+import Hints

17

18+initialize str = do

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

19+ (expr, hints') <- toDefs =<< tokenize str

19−

20+ subs <- unify (liftM2 (++) hints hints') (rename expr)

21+ return (seq subs expr)

20

22

23+{--

21initialize' str = do

24initialize' str = do

22 expr <- toDefs =<< tokenize str

25 expr <- toDefs =<< tokenize str

23-- let rexpr = rename expr

26-- let rexpr = rename expr

24-- let init = simp_loop rexpr

27-- let init = simp_loop rexpr

25-- return $ if depth init < depth rexpr then init else rexpr

28-- return $ if depth init < depth rexpr then init else rexpr

26 return $ rename expr

29 return $ rename expr

30+--}

27{--

31{--

28simp_loop exp = if exp == exp' then exp' else simp_loop exp'

32simp_loop exp = if exp == exp' then exp' else simp_loop exp'

29 where exp' = simp exp

33 where exp' = simp exp

src/Parse/ParseTypes.hs+52−40

@@ -2,56 +2,68 @@ module ParseTypes where

2

3import Ast

4import Combinators

5−import Data.Char (isUpper)

5+import Data.Char (isUpper,isLower)

6+import Data.Maybe (fromMaybe)

7+import Data.List (lookup)

6import ParserLib

8import ParserLib

7import Tokens

9import Tokens

8import Types

10import Types

11+import Guid

9import Control.Monad (liftM)

12import Control.Monad (liftM)

10

13

11−typeVar = do whitespace; t <- item

14+data ParseType = VarPT String

12− case t of

15+ | LambdaPT ParseType ParseType

13− ID "Int" -> return IntT

16+ | ADTPT String [ParseType]

14− ID "String" -> return StringT

17+

15− ID "Char" -> return CharT

18+listPT t = ADTPT "List" [t]

16− ID "Bool" -> return BoolT

19+tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

17− ID (v:vs) -> return (if isUpper v then ADT (v:vs) []

20+

18− else VarT 0) --(v:vs))

21+typeVar = liftM VarPT lowVar

19− _ -> zero

20−

21−typeList = do t LBRACKET; ti <- typeExpr; t RBRACKET; return $ ADT "List" []

22+typeList = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te

22typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN

23typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN

23− ; return $ case ts of { [t] -> t; _ -> ADT "Tuple" [] } }

24+ ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } }

25+typeUnambiguous = typeList +|+ typeTuple

24

26

25−typeUnamb = typeList +|+ typeTuple

27+typeSimple = liftM VarPT var

28+typeApp = do name <- capVar

29+ args <- star (typeSimple +|+ typeUnambiguous)

30+ return $ case args of

31+ [] -> VarPT name

32+ _ -> ADTPT name args

33+

34+typeExpr = do

35+ t1 <- typeVar +|+ typeApp +|+ typeUnambiguous

36+ arrow <- optional $ t ARROW

37+ case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr

38+ Nothing -> return t1

26

39

27−typeTerm = typeApp +|+ typeUnamb

40+typeConstructor = do name <- capVar

41+ args <- star (typeSimple +|+ typeUnambiguous)

42+ return $ (,) name args

28

43

29−typeApp = do

44+datatype = do

30− tipe <- typeVar

45+ t DATA ; name <- capVar ; args <- star lowVar ; assign

31− case tipe of

46+ tcs <- sepBy1 (opParser (=="|")) typeConstructor

32− ADT name _ -> AppT name `liftM` star typeTerm

47+ return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

33− _ -> return tipe

34

48

35−typeExpr = do t1 <- typeTerm

49+beta = VarT `liftM` guid

36− arrow <- optional $ t ARROW

37− case arrow of

38− Just ARROW -> LambdaT t1 `liftM` typeTerm

39− Nothing -> return t1

40

50

41−typeConstr = do

51+toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames

42− name <- capVar

52+ where argNames = map (("a"++) . show) [1..length args]

43− args <- star (typeVar +|+ typeUnamb)

44− return (Constructor name args)

45

53

46−constr (Constructor name args) =

54+toTypes name args constructors = do

47− (name, foldr Lambda (Data name (map Var argNames)) argNames)

55+ pairs <- mapM (\x -> (,) x `liftM` guid) args

48− where argNames = map (("arg"++) . show) [1..length args]

56+ return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors

49

57

50−datatype = do

58+toType pairs outType (name,args) =

51− t DATA

59+ foldr (==>) outType (map toT args)

52− adt <- capVar

60+ where toT (LambdaPT t1 t2) = toT t1 ==> toT t2

53− vs <- star var

61+ toT (ADTPT name args) = ADT name $ map toT args

54− assign

62+ toT (VarPT x@(c:_))

55− ts <- sepBy1 (opParser (=="|")) typeConstr

63+ | isLower c = VarT . fromMaybe (-1) $ lookup x pairs

56− -- (adt, foldr ForallT (ADT adt ts) vs)

64+ | otherwise = case x of "Int" -> IntT

57− return (map constr ts)

65+ "Number" -> IntT

66+ "String" -> StringT

67+ "Char" -> CharT

68+ "Bool" -> BoolT

69+ _ -> ADT x []

src/Parse/Parser.hs+11−7

@@ -3,21 +3,23 @@ module Parser where

3import Ast

4import Binop (binops)

5import Combinators

6+import Control.Monad (liftM)

6import Data.List (foldl')

7import Data.List (foldl')

8+import Guid

7import Lexer

9import Lexer

8import ParserLib

10import ParserLib

9import ParseTypes (datatype)

11import ParseTypes (datatype)

10import ParsePatterns

12import ParsePatterns

11import Tokens

13import Tokens

12−import Control.Monad (liftM)

14+import Types (Type (VarT))

13

15

14-------- Basic Terms --------

16-------- Basic Terms --------

15

17

16numTerm = do { whitespace; t <- item

18numTerm = do { whitespace; t <- item

17− ; case t of { NUMBER n -> return $ Number n; _ -> zero } }

19+ ; case t of { NUMBER n -> return $ Number n; _ -> zero } }

18strTerm = do { whitespace; t <- item

20strTerm = do { whitespace; t <- item

19− ; case t of { STRING cs -> return . list $ map Chr cs

21+ ; case t of { STRING cs -> return . list $ map Chr cs

20− ; _ -> zero } }

22+ ; _ -> zero } }

21

23

22varTerm = Var `liftM` var

24varTerm = Var `liftM` var

23chrTerm = Chr `liftM` chr

25chrTerm = Chr `liftM` chr

@@ -105,12 +107,14 @@ expr = select [ letExpr

105 , lambdaExpr

107 , lambdaExpr

106 ]

108 ]

107

109

108−def = (:[]) `liftM` assignExprNospace

110+def = do (f,e) <- assignExprNospace

111+ return ([f], [e], guid >>= \x -> return [VarT x])

109

112

110defs = do

113defs = do

111− ds <- plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)

114+ (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)

115+ let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)

112 star $ sat (==NEWLINE) +|+ sat (==SPACES)

116 star $ sat (==NEWLINE) +|+ sat (==SPACES)

113− return $ Let (concat ds) (Var "main")

117+ return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)

114

118

115err = "Parse Error: Better error messages to come!"

119err = "Parse Error: Better error messages to come!"

116toExpr = extractResult err . parse expr

120toExpr = extractResult err . parse expr

src/Parse/ParserLib.hs+6−5

@@ -2,15 +2,16 @@ module ParserLib where

2

3import Ast

4import Combinators

5−import Data.Char (isUpper)

5+import Data.Char (isUpper,isLower)

6−import Control.Monad (liftM)

6+import Control.Monad (liftM,guard)

7import Tokens

8

9varNoSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } }

10var = whitespace >> varNoSpace

11−capVar = do

12− whitespace; t <- item

11+capVar = do whitespace; t <- item

13− case t of { ID (v:vs) -> if isUpper v then return (v:vs) else zero }

12+ case t of { ID (v:vs) -> guard (isUpper v) >> return (v:vs) ; _ -> zero }

13+lowVar = do whitespace; t <- item

14+ case t of { ID (v:vs) -> guard (isLower v) >> return (v:vs) ; _ -> zero }

14

15

15chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } }

16chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } }

16

17

src/Types/Constrain.hs+1−2

@@ -8,7 +8,6 @@ import qualified Data.Map as Map

8import Control.Monad (liftM,mapM)

9import Control.Monad.State (evalState)

10import Guid

11−import Hints

12

11

13data Constraint = Type :=: Type

12data Constraint = Type :=: Type

14 | Type :<: Type

13 | Type :<: Type

@@ -19,7 +18,7 @@ beta = VarT `liftM` guid

19unionA = Map.unionWith (++)

18unionA = Map.unionWith (++)

20unionsA = Map.unionsWith (++)

19unionsA = Map.unionsWith (++)

21

20

22−constrain expr = run $ do

21+constrain hints expr = do

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

22 (as,cs,t) <- inference expr

24 hs <- hints

23 hs <- hints

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

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

src/Types/Hints.hs+7−18

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

6import Types

7import Guid

8

9−element = ADT "Element" []

10−direction = ADT "Direction" []

11−text = ADT "Text" []

12−listOf t = ADT "List" [t]

13−tuple2 a b = ADT "Tuple2" [a,b]

14−string = listOf CharT

15−

16−infixr ==>

17−t1 ==> t2 = LambdaT t1 t2

18−

19−infix 8 -:

20−name -: tipe = (,) name tipe

21−

22−hasType t = map (-: t)

23

9

24-------- Text and Elements --------

10-------- Text and Elements --------

25

11

@@ -30,11 +16,12 @@ textToText = ["header", "italic", "bold", "underline"

30

16

31textAttrs = [ "toText" -: string ==> text

17textAttrs = [ "toText" -: string ==> text

32 , "link" -: string ==> text ==> text

18 , "link" -: string ==> text ==> text

33− , "height" -: IntT ==> text ==> text

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

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

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

35

21

36elements = let iee = IntT ==> element ==> element in

22elements = let iee = IntT ==> element ==> element in

37 [ "flow" -: direction ==> listOf element ==> element

23 [ "flow" -: direction ==> listOf element ==> element

24+ , "layers" -: listOf element ==> element

38 , "opacity" -: iee

25 , "opacity" -: iee

39 , "width" -: iee

26 , "width" -: iee

40 , "height" -: iee

27 , "height" -: iee

@@ -100,7 +87,7 @@ lists = liftM (map (first ("List."++)) . (++ints)) . sequence $

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

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

101 , do a <- var ; "intersperse" -:: a ==> listOf a ==> listOf a

88 , do a <- var ; "intersperse" -:: a ==> listOf a ==> listOf a

102 , do a <- var ; "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a

89 , do a <- var ; "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a

103− , do [a,b] <- vars 2 ; "zip" -:: listOf a ==>listOf b ==>listOf(tuple2 a b)

90+ , do [a,b] <- vars 2 ; "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])

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

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

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

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

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

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

@@ -113,5 +100,7 @@ lists = liftM (map (first ("List."++)) . (++ints)) . sequence $

113

100

114-------- Everything --------

101-------- Everything --------

115

102

103+hints = do

116−hints = do fs <- funcs ; ls <- lists

104+ fs <- funcs ; ls <- lists

105+ return $ fs ++ ls ++ math ++ bool

117− return $ fs ++ ls ++ str2elem ++ textAttrs ++ elements ++ math ++ bool

106+ {--++ str2elem ++ textAttrs ++ elements--}

src/Types/Types.hs+16−4

@@ -12,13 +12,25 @@ data Type = IntT

12 | BoolT

13 | LambdaT Type Type

14 | VarT X

15− | AppT String [Type]

16 | ADT String [Type]

15 | ADT String [Type]

17 deriving (Eq, Ord)

16 deriving (Eq, Ord)

18

17

19data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show)

18data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show)

20

19

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

20+element = ADT "Element" []

21+direction = ADT "Direction" []

22+text = ADT "Text" []

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

24+tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts

25+string = listOf CharT

26+

27+infixr ==>

28+t1 ==> t2 = LambdaT t1 t2

29+

30+infix 8 -:

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

32+

33+hasType t = map (-: t)

22

34

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

35parens = ("("++) . (++")")

24

36

@@ -29,9 +41,9 @@ instance Show Type where

29 ; StringT -> "String"

41 ; StringT -> "String"

30 ; CharT -> "Char"

42 ; CharT -> "Char"

31 ; BoolT -> "Bool"

43 ; BoolT -> "Bool"

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

44+ ; LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2

45+ ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

33 ; VarT x -> show x

46 ; VarT x -> show x

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

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

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

36 ; ADT name [] -> name

48 ; ADT name [] -> name

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

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

src/Types/Unify.hs+23−23

@@ -3,36 +3,26 @@ module Unify where

3

4import Constrain

5import Control.Arrow (second)

6+import Control.Monad (liftM)

7+import qualified Data.Set as Set

6import Types

8import Types

7

9

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

10+import Guid

9

11

12+unify hints expr = run $ do

13+ cs <- constrain hints expr

10−solver [] subs = Right subs

14+ solver cs []

11

15

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

16+solver [] subs = return $ Right subs

13

17

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

18+-------- Destruct Type-constructors --------

15− solver cs subs

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

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

18

19

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

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

20− solver cs subs

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

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

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

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

23−

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

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

26−

27solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs =

23solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs =

28 solver ([ t1 :=: t1', t2 :=: t2' ] ++ cs) subs

24 solver ([ t1 :=: t1', t2 :=: t2' ] ++ cs) subs

29

25

30−-------- subtypes --------

31−

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

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

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

35−

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

26-------- Type-equality --------

37

27

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

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

@@ -42,16 +32,26 @@ solver ((t :=: VarT x) : cs) subs =

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

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

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

33 if t1 /= t2 then uniError t1 t2 else solver cs subs

44

34

35+-------- subtypes --------

36+

37+solver ((t1 :<: t2) : cs) subs = do

38+ let f x = do y <- guid ; return (x,VarT y)

39+ t2' <- foldr (uncurry tSub) t2 `liftM` (mapM f . Set.toList $ getVars t2)

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

41+

45

42

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

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

47cSub k v (t1 :<: t2) = tSub k v t1 :<: tSub k v t2

44cSub k v (t1 :<: t2) = tSub k v t1 :<: tSub k v t2

48

45

49tSub k v (VarT x) = if k == x then v else (VarT x)

46tSub k v (VarT x) = if k == x then v else (VarT x)

50tSub k v (LambdaT t1 t2) = LambdaT (tSub k v t1) (tSub k v t2)

47tSub k v (LambdaT t1 t2) = LambdaT (tSub k v t1) (tSub k v t2)

48+tSub k v (ADT name ts) = ADT name (map (tSub k v) ts)

51tSub _ _ t = t

49tSub _ _ t = t

52

50

53−isSubtype (_ :<: _) = True

51+getVars (VarT x) = Set.singleton x

54−isSubtype _ = False

52+getVars (LambdaT t1 t2) = Set.union (getVars t1) (getVars t2)

53+getVars (ADT name ts) = Set.unions $ map getVars ts

54+getVars _ = Set.empty

55

56uniError t1 t2 =

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

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