e75937e · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Final fixes for use of type schemes.

e75937eevancz14 years ago

elm/src/Initialize.hs+3−2

compare with master

unifiedsplit

@@ -8,6 +8,7 @@ import Parser (parseProgram)

8import Hints

9import Unify

10import Rename

11+import Types ((-:))

11import Optimize

12import Optimize

@@ -15,7 +16,7 @@ initialize str = do

15 (Module name ex im defs (ims,exs), tipes) <- parseProgram str

16 (Module name ex im defs (ims,exs), tipes) <- parseProgram str

16 let (Let ds _) = rename . Let defs $ Var "_"

17 let (Let ds _) = rename . Let defs $ Var "_"

17 let dict n = maybe n id . lookup n $ zip (map fst defs) (map fst ds)

18 let dict n = maybe n id . lookup n $ zip (map fst defs) (map fst ds)

18− let allHints = liftM2 (\a b -> a ++ b ++ ffiHints (ims,exs)) hints tipes

19+ let allHints = hints ++ tipes ++ ffiHints (ims,exs)

19 subs <- unify allHints . Let ds $ checkFFI dict ims exs

20 subs <- unify allHints . Let ds $ checkFFI dict ims exs

20 let Let defs' _ = optimize (Let ds $ Var "_")

21 let Let defs' _ = optimize (Let ds $ Var "_")

21 let im' = if any ((=="Prelude") . fst) im then im else

22 let im' = if any ((=="Prelude") . fst) im then im else

@@ -25,7 +26,7 @@ initialize str = do

27ffiHints (ims,exs) =

28ffiHints (ims,exs) =

28− map (\(_,_,n,t) -> (n,t)) ims ++ map (\(_,n,t) -> (n,t)) exs

29+ map (\(_,_,n,t) -> n -: t) ims ++ map (\(_,n,t) -> n -: t) exs

30checkFFI dict ims exs = list $ ims' ++ exs'

31checkFFI dict ims exs = list $ ims' ++ exs'

31 where ims' = map (\(_,b,n,_)-> Binop "==" (Var n) (App (Var "constant") b)) ims

32 where ims' = map (\(_,b,n,_)-> Binop "==" (Var n) (App (Var "constant") b)) ims

elm/src/Parse/ParseTypes.hs+11−12

@@ -52,7 +52,7 @@ typeExpr = do

52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])

53typeConstructor = (,) <$> (capVar <?> "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous)

55−datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])

55+datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], [Scheme])

56datatype = do

57 reserved "data" <?> "datatype definition (data T = A | B | ...)"

58 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

@@ -65,22 +65,21 @@ beta = liftM VarT guid

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

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

68−toTypes name args constructors = do

68+toTypes name args constructors =

69− pairs <- mapM (\x -> (,) x `liftM` guid) args

70− return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors

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

70+ where pairs = zip args [1..length args]

72toType pairs outType (name,args) =

73− foldr (==>) outType (map toT args)

73+ Forall [1..n+2] cs $ foldr (==>) outType (map toT args)

74+ where n = length pairs

75+ cs = [ VarT (n+1) :<: time, VarT (n+2) :<: number ]

74− where toT (LambdaPT t1 t2) = toT t1 ==> toT t2

76+ toT (LambdaPT t1 t2) = toT t1 ==> toT t2

75 toT (ADTPT name args) = ADT name $ map toT args

77 toT (ADTPT name args) = ADT name $ map toT args

76 toT (VarPT x@(c:_))

78 toT (VarPT x@(c:_))

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

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

80+ | x == "Time" = VarT (n+1)

81+ | x == "Number" = VarT (n+2)

78− | otherwise = case x of "Int" -> IntT

82+ | otherwise = ADT x []

79− "Number" -> IntT

80− "String" -> StringT

81− "Char" -> CharT

82− "Bool" -> BoolT

83− _ -> ADT x []

85toForeignType (LambdaPT t1 t2) =

84toForeignType (LambdaPT t1 t2) =

86 fail $ "Elm's JavaScript event interface does not yet handle functions. " ++

85 fail $ "Elm's JavaScript event interface does not yet handle functions. " ++

elm/src/Parse/Parser.hs+3−4

@@ -21,9 +21,8 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

21defs1 = do d <- datatype <|> def <?> "at least one datatype or variable definition"

22 (d:) <$> many freshDef

24−defs = do

25− (fss,ess,tss) <- unzip3 <$> defs1

24+defs = do (fss,ess,tss) <- unzip3 <$> defs1

26− return (concat fss, concat ess, concat `liftM` sequence tss)

25+ return (concat fss, concat ess, concat tss)

28program = do

27program = do

29 optional freshLine

28 optional freshLine

@@ -33,7 +32,7 @@ program = do

33 jsffi <- foreignDefs `followedBy` freshLine <|> return ([],[])

32 jsffi <- foreignDefs `followedBy` freshLine <|> return ([],[])

34 (vs,es,ts) <- defs

33 (vs,es,ts) <- defs

35 optional freshLine ; optional spaces ; eof

34 optional freshLine ; optional spaces ; eof

36− return (Module names exports is (zip vs es) jsffi, zip vs `liftM` ts)

35+ return (Module names exports is (zip vs es) jsffi, zip vs ts)

38parseProgram source =

37parseProgram source =

39 case parse program "" source of

38 case parse program "" source of