79e465c · elk · git.iko.soy

elm/src/Ast.hs+5−4

compare with master

unifiedsplit

@@ -6,15 +6,13 @@ import Data.List (intercalate)

6import Types

7import Guid

8

9−data Module = Module [String] Exports Imports Defs JSFFI

9+data Module = Module [String] Exports Imports [Definition] JSFFI

10

11type Exports = [String]

12

13type Imports = [(String, ImportMethod)]

14data ImportMethod = As String | Hiding [String] | Importing [String]

15

16−type Defs = [(String,Expr)]

17−

18type JSFFI = ( [(String, Expr, String, Type)]

16type JSFFI = ( [(String, Expr, String, Type)]

19 , [(String, String, Type)] )

17 , [(String, String, Type)] )

20

18

@@ -37,12 +35,15 @@ data Expr = IntNum Int

37 | Fold Expr Expr Expr

35 | Fold Expr Expr Expr

38 | Async Expr

36 | Async Expr

39 | Input String

37 | Input String

40− | Let [(String,Expr)] Expr

38+ | Let [Definition] Expr

41 | Var String

39 | Var String

42 | Case Expr [(Pattern,Expr)]

40 | Case Expr [(Pattern,Expr)]

43 | Data String [Expr]

41 | Data String [Expr]

44 deriving (Show, Eq)

42 deriving (Show, Eq)

45

43

44+data Definition = Definition String [String] Expr

45+ deriving (Show, Eq)

46+

46cons h t = Data "Cons" [h,t]

47cons h t = Data "Cons" [h,t]

47nil = Data "Nil" []

48nil = Data "Nil" []

48list = foldr cons nil

49list = foldr cons nil

elm/src/Gen/CompileToJS.hs+6−7

@@ -54,7 +54,7 @@ jsModule (Module names exports imports defs foreigns) =

54 body = jsDefs defs

55 export = ret . braces . intercalate "," $ mapMaybe getNames defs

56 exps = if null exports then ["main"] else exports

57− getNames (x,_) =

57+ getNames (Definition x _ _) =

58 let y = reverse . tail . dropWhile isDigit $ reverse x in

59 if y `elem` exps then Just $ y ++ ":" ++ x else Nothing

60 (ims,exs) = let (i,e) = foreigns in

@@ -115,12 +115,11 @@ toJS expr =

115jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"

116

117jsDefs defs = concatMap toDef $ sortBy f defs

118− where f a b = compare (isLambda a) (isLambda b)

118+ where f a b = compare (valueOf a) (valueOf b)

119− isLambda (_, Lambda _ _) = 1

119+ valueOf (Definition _ args _) = min 1 (length args)

120− isLambda _ = 0

120+ toDef (Definition x [] e) = assign x (toJS e)

121− toDef (f, Lambda x e) =

121+ toDef (Definition f (a:as) e) =

122− "\nfunction " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"

122+ "\nfunction " ++ f ++ parens a ++ braces (ret . toJS $ foldr Lambda e as) ++ ";"

123− toDef (x, e) = assign x (toJS e)

124

123

125jsCase e [c] = jsMatch c ++ parens (toJS e)

124jsCase e [c] = jsMatch c ++ parens (toJS e)

126jsCase e cases = "(function(){" ++

125jsCase e cases = "(function(){" ++

elm/src/Gen/ExtractNoscript.hs+3−5

@@ -4,7 +4,7 @@ module ExtractNoscript (extract) where

4import Ast

5

6extract (Module _ _ _ defs _) =

7− concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (extract' . snd) defs

7+ concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (\(Definition _ _ e) -> extract' e) defs

8

9extract' expr =

10 let f = extract' in

@@ -24,12 +24,10 @@ extract' expr =

24 App (Var "monospace") e -> tag "code" e

25 App e1 e2 -> f e1 ++ f e2

26 If eb et ef -> f et ++ f ef

27− Let defs e -> concatMap (f . snd) defs ++ f e

27+ Let defs e -> concatMap (\(Definition _ _ d) -> f d) defs ++ f e

28 Var _ -> []

29 Case e cases -> concatMap (f . snd) cases

30 Data _ es -> concatMap f es

31 _ -> []

32

33−tag t e = case extract' e of

34− [s] -> [ concat [ "<", t, ">", s, "</", t, ">" ] ]

33+tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract' e)

35− ss -> ss

elm/src/Initialize.hs+12−11

@@ -12,17 +12,18 @@ import Types ((-:))

12import Optimize

13

14

15−initialize str = do

15+initialize str =

16+ let nameOf (Definition n _ _) = n in

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

17+ do (Module name ex im defs (ims,exs), tipes) <- parseProgram str

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

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

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

19+ let dict n = maybe n id . lookup n $ zip (map nameOf defs) (map nameOf ds)

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

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

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

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

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

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

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

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

23− ("Prelude", Importing []):im

24+ ("Prelude", Importing []):im

24− let exs' = map (\(js,n,t) -> (js,dict n,t)) exs

25+ let exs' = map (\(js,n,t) -> (js,dict n,t)) exs

25− return (subs `seq` Module name ex im' defs' (ims,exs'))

26+ return (subs `seq` Module name ex im' defs' (ims,exs'))

26

27

28

28ffiHints (ims,exs) =

29ffiHints (ims,exs) =

elm/src/Optimize.hs+2−1

@@ -16,7 +16,8 @@ simp expr =

16 Lambda x e -> Lambda x (f e)

17 App e1 e2 -> App (f e1) (f e2)

18 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)

19− Let defs e -> Let (map (second f) defs) (f e)

19+ Let defs e -> Let (map simpDef defs) (f e)

20+ where simpDef (Definition func args e) = Definition func args (f e)

20 Data name es -> Data name (map f es)

21 Data name es -> Data name (map f es)

21 Case e cases -> Case (f e) (map (second f) cases)

22 Case e cases -> Case (f e) (map (second f) cases)

22 _ -> expr

23 _ -> expr

elm/src/Parse/ParseExpr.hs+7−3

@@ -80,10 +80,10 @@ ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace

80

81lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

82 whitespace

83− args <- spaceSep1 patternTerm

83+ pats <- spaceSep1 patternTerm

84 whitespace ; arrow ; whitespace

85 e <- expr

86− return $ makeFunction args e

86+ return $ makeLambda pats e

87

88letExpr = do

89 reserved "let"

@@ -118,8 +118,12 @@ assignExpr = do

118 flattenPatterns patterns exp

119

120

121+def = do ds <- assignExpr

122+ return (ds,[])

123+{--

121−def = do (fs,es) <- unzip <$> assignExpr

124+ do (fs,es) <- unzip <$> assignExpr

122 return (fs, es, map (\_ -> Forall [0] [] (VarT 0)) fs)

125 return (fs, es, map (\_ -> Forall [0] [] (VarT 0)) fs)

126+--}

123

127

124parseDef str =

128parseDef str =

125 case parse def "" str of

129 case parse def "" str of

elm/src/Parse/ParseTypes.hs+22−16

@@ -52,34 +52,40 @@ typeExpr = do

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

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

54

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

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

56datatype = do

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

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

59 whitespace ; string "=" ; whitespace

60 tcs <- pipeSep1 typeConstructor

61− return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

61+ case getConstraints name args tcs of

62+ Right cs -> return (map toDef tcs, cs)

63+ Left msg -> fail msg

62

64

63beta = liftM VarT guid

65beta = liftM VarT guid

64

66

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

67+toDef (name,types) = Definition name args (Data name (map Var args))

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

68+ where args = map (('a':) . show) [1..length types]

67

69

68−toTypes name args constructors =

70+getConstraints name args constructors =

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

71+ mapM (toConstraint tvarDict . ADT name $ map (VarT . snd) tvarDict) constructors

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

72+ where tvarDict = zip args [1..length args]

71

73

72−toType pairs outType (name,args) =

74+toConstraint tvarDict outType (name,args) =

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

75+ ((,) name . Forall [1..n+2] cs . foldr (==>) outType) <$> mapM toT args

74− where n = length pairs

76+ where n = length tvarDict

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

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

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

78+ toT (LambdaPT t1 t2) = (==>) <$> toT t1 <*> toT t2

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

79+ toT (ADTPT name args) = ADT name <$> mapM toT args

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

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

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

81+ | isLower c = VarT <$> case lookup x tvarDict of

82+ Just v -> Right v

83+ Nothing -> Left $ msg x

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

84+ | x == "Time" = return $ VarT (n+1)

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

85+ | x == "Number" = return $ VarT (n+2)

82− | otherwise = ADT x []

86+ | otherwise = return $ ADT x []

87+ msg x = "Type variable '" ++ x ++

88+ "' is unbound in type constructor '" ++ name ++ "'."

83

89

84toForeignType (LambdaPT t1 t2) =

90toForeignType (LambdaPT t1 t2) =

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

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

elm/src/Parse/Parser.hs+2−5

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

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

22 (d:) <$> many freshDef

23

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

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

26−

27program = do

24program = do

28 optional freshLine

25 optional freshLine

29 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

26 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

30 is <- (do try (lookAhead $ reserved "import")

27 is <- (do try (lookAhead $ reserved "import")

31 imports `followedBy` freshLine) <|> return []

28 imports `followedBy` freshLine) <|> return []

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

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

33− (vs,es,ts) <- defs

30+ (defss, schemess) <- unzip <$> defs1

34 optional freshLine ; optional spaces ; eof

31 optional freshLine ; optional spaces ; eof

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

32+ return (Module names exports is (concat defss) jsffi, concat schemess)

36

33

37parseProgram source =

34parseProgram source =

38 case parse program "" source of

35 case parse program "" source of

elm/src/Parse/Patterns.hs+15−12

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

1−module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where

1+module Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

2

3import Ast

4import Data.Char (isUpper)

@@ -29,25 +29,28 @@ patternExpr :: Monad m => ParsecT [Char] u m Pattern

29patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"

30

31

32+makeLambda pats body = foldr Lambda (makeBody pats body) (map getName pats)

32

33

33−makeFunction args body = foldr func body args

34+makeBody pats body = foldr func body pats

34− where func PAnything e = Lambda "_" e

35+ where func PAnything e = e

35− func (PVar x) e = Lambda x e

36+ func (PVar x) e = e

36− func p e = "t" `Lambda` Case (Var "t") [(p,e)]

37+ func p e = Case (Var $ getName p) [(p,e)]

37

38

38−flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)]

39+flattenPatterns (PVar f : args) exp =

40+ return [ Definition f (map getName args) (makeBody args exp) ]

39flattenPatterns [p] exp = return $ matchSingle p exp p

41flattenPatterns [p] exp = return $ matchSingle p exp p

40flattenPatterns ps _ =

42flattenPatterns ps _ =

41 fail $ "Pattern (" ++ unwords (map show ps) ++

43 fail $ "Pattern (" ++ unwords (map show ps) ++

42 ") cannot be used on the left-hand side of an assign statement."

44 ") cannot be used on the left-hand side of an assign statement."

43

45

44matchSingle pat exp p@(PData _ ps) =

46matchSingle pat exp p@(PData _ ps) =

45− (v, exp) : concatMap (matchSingle p $ Var v) ps

47+ (Definition v [] exp) : concatMap (matchSingle p $ Var v) ps

46− where v = "'" ++ getName p

48+ where v = getName p

47−matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ]

49+matchSingle pat exp (PVar x) = [ Definition x [] (Case exp [(pat,Var x)]) ]

48matchSingle pat exp PAnything = []

50matchSingle pat exp PAnything = []

49

51

52+getName p = f p

50−getName (PData n ps) = n ++ concatMap getName ps

53+ where f (PData n ps) = n ++ "$" ++ concatMap getName ps

51−getName (PAnything) = "_"

54+ f (PAnything) = "_"

52−getName (PVar x) = x

55+ f (PVar x) = x

53

56

elm/src/Rename.hs+5−5

@@ -48,11 +48,11 @@ rename' env expr =

48

49 Async e -> Async `liftM` rnm e

50

51− Let defs e -> do

51+ Let defs e ->

52− let (vs,es) = unzip defs

52+ let (fs,argss,es) = unzip3 $ map (\(Definition a b c) -> (a,b,c)) defs in

53− env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs

53+ do env' <- foldM (\acc x -> snd `liftM` extend acc x) env fs

54− es' <- mapM (rename' env') es; re <- rename' env' e

54+ es' <- mapM (rename' env') es; re <- rename' env' e

55− return $ Let (zip (map env' vs) es') re

55+ return $ Let (zipWith3 Definition (map env' fs) argss es') re

56

57 Var x -> return . Var $ env x

58

elm/src/Types/Constrain.hs+34−8

@@ -38,16 +38,23 @@ inference (Lambda x e) =

38 Map.findWithDefault [] x a

39 , LambdaT b t )

40inference (Let defs e) =

41− do (a,c,t) <- inference e

41+ do (as,cs,t) <- inference e

42− let (xs,es) = unzip defs

42+ (ass, schemes) <- liftM unzip (mapM defScheme defs)

43− (as,cs,ts) <- unzip3 `liftM` mapM inference es

44− let assumptions = unionsA (a:as)

43+ let assumptions = unionsA (as:ass)

44+ let names = map (\(Definition x _ _) -> x) defs

45− let f x t = map (:=: t) . map VarT $ Map.findWithDefault [] x assumptions

45+ let genCs name s = map (\x -> VarT x :<<: s) $ Map.findWithDefault [] name assumptions

46− let constraints = Set.fromList . concat $ zipWith f xs ts

46+ let cs' = Set.fromList . concat $ zipWith genCs names schemes

47− return ( foldr Map.delete assumptions xs

47+ return ( foldr Map.delete assumptions names

48− , Set.unions $ c:constraints:cs

48+ , Set.union cs' cs

49 , t )

50

51+inference (Case e cases) =

52+ do (as,cs,t) <- inference e

53+ (ass,css,ts) <- liftM unzip3 $ mapM (caseInference t) cases

54+ return ( unionsA $ as:ass

55+ , Set.unions $ Set.fromList (zipWith (:=:) ts $ tail ts) : cs : css

56+ , head ts)

57+

51inference (If e1 e2 e3) =

58inference (If e1 e2 e3) =

52 do (a1,c1,t1) <- inference e1

59 do (a1,c1,t1) <- inference e1

53 (a2,c2,t2) <- inference e2

60 (a2,c2,t2) <- inference e2

@@ -72,3 +79,22 @@ inference other =

72 _ -> beta >>= primitive

79 _ -> beta >>= primitive

73

80

74primitive t = return (Map.empty, Set.empty, t)

81primitive t = return (Map.empty, Set.empty, t)

82+

83+caseInference tipe (p,e) = do

84+ (as,cs,t) <- inference e

85+ return ( foldr Map.delete as (namesIn p)

86+ , cs

87+ , t)

88+

89+namesIn PAnything = []

90+namesIn (PVar v) = [v]

91+namesIn (PData name ps) = concatMap namesIn ps

92+

93+defScheme (Definition name args e) =

94+ do argDict <- mapM (\a -> liftM ((,) a) guid) args

95+ (as,cs,t) <- inference e

96+ let genCs (arg,x) = map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [] arg as

97+ let cs' = concatMap genCs argDict

98+ let tipe = foldr (==>) t $ map (VarT . snd) argDict

99+ return (foldr Map.delete as args

100+ , Forall (map snd argDict) (cs' ++ Set.toList cs) tipe)