git.iko.soy/elk
on master help sign in
Use fewer local vars
c33ca8aEvan Czaplicki
compiler/AST/Expression/General.hs+2−2
compare with master
unifiedsplit
@@ -83,7 +83,7 @@ saveEnvName = "_save_the_environment!!!"
83
83
84dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
84dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
85dummyLet defs =
85dummyLet defs =
86− Annotation.none $ Let defs (Annotation.none $ localVar saveEnvName)
86+ Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))
87
87
88instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
88instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
89 pretty expr =
89 pretty expr =
@@ -191,5 +191,5 @@ prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
191 MultiIf _ -> True
191 MultiIf _ -> True
192 Let _ _ -> True
192 Let _ _ -> True
193 Case _ _ -> True
193 Case _ _ -> True
194− Data name (_:_) -> name /= "::"
194+ Data name (_:_) -> not (name == "::" || Help.isTuple name)
195 _ -> False
195 _ -> False
compiler/AST/Variable.hs+51−9
@@ -4,15 +4,16 @@ module AST.Variable where
4import Data.Binary
4import Data.Binary
5import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
6import Text.PrettyPrint as P
6import Text.PrettyPrint as P
7+import qualified AST.Helpers as Help
7import AST.PrettyPrint
8import AST.PrettyPrint
8
9
9newtype Raw = Raw String
10newtype Raw = Raw String
10 deriving (Eq,Ord,Show)
11 deriving (Eq,Ord,Show)
11
12
12data Home
13data Home
13− = Local
14− | BuiltIn
14+ = BuiltIn
15 | Module !String
15 | Module !String
16+ | Local
16 deriving (Eq,Ord,Show)
17 deriving (Eq,Ord,Show)
17
18
18data Canonical = Canonical
19data Canonical = Canonical
@@ -26,6 +27,47 @@ local x = Canonical Local x
26builtin :: String -> Canonical
27builtin :: String -> Canonical
27builtin x = Canonical BuiltIn x
28builtin x = Canonical BuiltIn x
28
29
30+-- To help with pattern matching on some common canonical variables:
31+is :: String -> String -> Canonical -> Bool
32+is home name var =
33+ var == Canonical (Module home) name
34+
35+isJson :: Canonical -> Bool
36+isJson = is "Json" "Value"
37+
38+isMaybe :: Canonical -> Bool
39+isMaybe = is "Maybe" "Maybe"
40+
41+isArray :: Canonical -> Bool
42+isArray = is "Array" "Array"
43+
44+isSignal :: Canonical -> Bool
45+isSignal = is "Signal" "Signal"
46+
47+isList :: Canonical -> Bool
48+isList v = v == Canonical BuiltIn "_List"
49+
50+isTuple :: Canonical -> Bool
51+isTuple v =
52+ case v of
53+ Canonical BuiltIn name -> Help.isTuple name
54+ _ -> False
55+
56+isPrimitive :: Canonical -> Bool
57+isPrimitive v =
58+ case v of
59+ Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
60+ _ -> False
61+
62+isPrim :: String -> Canonical -> Bool
63+isPrim prim v =
64+ case v of
65+ Canonical BuiltIn name -> name == prim
66+ _ -> False
67+
68+isText :: Canonical -> Bool
69+isText = is "Text" "Text"
70+
29class ToString a where
71class ToString a where
30 toString :: a -> String
72 toString :: a -> String
31
73
@@ -35,9 +77,9 @@ instance ToString Raw where
35instance ToString Canonical where
77instance ToString Canonical where
36 toString (Canonical home name) =
78 toString (Canonical home name) =
37 case home of
79 case home of
38− Local -> name
39 BuiltIn -> name
80 BuiltIn -> name
40 Module path -> path ++ "." ++ name
81 Module path -> path ++ "." ++ name
82+ Local -> name
41
83
42-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
84-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
43data Listing a = Listing
85data Listing a = Listing
@@ -78,15 +120,15 @@ instance Pretty Value where
78instance Binary Canonical where
120instance Binary Canonical where
79 put (Canonical home name) =
121 put (Canonical home name) =
80 case home of
122 case home of
81− Local -> putWord8 0 >> put name
123+ BuiltIn -> putWord8 0 >> put name
82− BuiltIn -> putWord8 1 >> put name
124+ Module path -> putWord8 1 >> put path >> put name
83− Module path -> putWord8 2 >> put path >> put name
125+ Local -> putWord8 2 >> put name
84
126
85 get = do tag <- getWord8
127 get = do tag <- getWord8
86 case tag of
128 case tag of
87− 0 -> Canonical Local <$> get
129+ 0 -> Canonical BuiltIn <$> get
88− 1 -> Canonical BuiltIn <$> get
89− 2 -> Canonical . Module <$> get <*> get
130+ 1 -> Canonical . Module <$> get <*> get
131+ 2 -> Canonical Local <$> get
90 _ -> error "Unexpected tag when deserializing canonical variable"
132 _ -> error "Unexpected tag when deserializing canonical variable"
91
133
92instance Binary Value where
134instance Binary Value where
compiler/Transform/Canonicalize.hs+31−12
@@ -30,10 +30,11 @@ import qualified Transform.SortDefinitions as Transform
30import qualified Transform.Declaration as Transform
30import qualified Transform.Declaration as Transform
31
31
32environment :: Interfaces -> Module.ValidModule -> Either [Doc] Environment
32environment :: Interfaces -> Module.ValidModule -> Either [Doc] Environment
33−environment interfaces (Module.Module _ _ _ ims decls) =
33+environment interfaces m@(Module.Module _ _ _ ims decls) =
34 do () <- allImportsAvailable interfaces ims
34 do () <- allImportsAvailable interfaces ims
35 nonLocalEnv <- foldM (toEnv interfaces) Env.builtIns ims
35 nonLocalEnv <- foldM (toEnv interfaces) Env.builtIns ims
36+ let moduleName = Module.getName m
36− foldM addDecl nonLocalEnv decls
37+ foldM (addDecl moduleName) nonLocalEnv decls
37
38
38toEnv :: Interfaces -> Environment -> (String, ImportMethod) -> Either [Doc] Environment
39toEnv :: Interfaces -> Environment -> (String, ImportMethod) -> Either [Doc] Environment
39toEnv interfaces environ (name,method)
40toEnv interfaces environ (name,method)
@@ -72,9 +73,9 @@ addValue :: String -> Module.Interface -> Environment -> Var.Value
72 -> Either [Doc] Environment
73 -> Either [Doc] Environment
73addValue name interface env value =
74addValue name interface env value =
74 let insert' x = insert x (Var.Canonical (Var.Module name) x)
75 let insert' x = insert x (Var.Canonical (Var.Module name) x)
75− notFound x = Left [ P.text $
76− "Import Error: Could not import value '" ++ name ++ "." ++ x ++ "'.\n" ++
76+ msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
77− " It is not exported by module " ++ name ++ "." ]
77+ "'.\n It is not exported by module " ++ name ++ "."
78+ notFound x = Left [ P.text (msg x) ]
78 in
79 in
79 case value of
80 case value of
80 Var.Value x
81 Var.Value x
@@ -106,8 +107,9 @@ addValue name interface env value =
106 [] -> return names
107 [] -> return names
107 c:_ -> notFound c
108 c:_ -> notFound c
108
109
109−addDecl :: Environment -> D.ValidDecl -> Either [Doc] Environment
110+addDecl :: String -> Environment -> D.ValidDecl -> Either [Doc] Environment
110−addDecl env decl =
111+addDecl moduleName env decl =
112+ let typeVar = Var.Canonical (Var.Module moduleName) in
111 case decl of
113 case decl of
112 D.Definition (Valid.Definition pattern _ _) ->
114 D.Definition (Valid.Definition pattern _ _) ->
113 return $ env
115 return $ env
@@ -118,19 +120,19 @@ addDecl env decl =
118 D.Datatype name _ ctors ->
120 D.Datatype name _ ctors ->
119 return $ env
121 return $ env
120 { _values = addCtors (_values env)
122 { _values = addCtors (_values env)
121− , _adts = insert name (Var.local name) (_adts env)
123+ , _adts = insert name (typeVar name) (_adts env)
122 , _patterns = addCtors (_patterns env)
124 , _patterns = addCtors (_patterns env)
123 }
125 }
124 where
126 where
125 addCtors e = foldr add e (map fst ctors)
127 addCtors e = foldr add e (map fst ctors)
126− add name e = insert name (Var.local name) e
128+ add name e = insert name (typeVar name) e
127
129
128 D.TypeAlias name tvars alias ->
130 D.TypeAlias name tvars alias ->
129 do alias' <- Either.either throw return (tipe env alias)
131 do alias' <- Either.either throw return (tipe env alias)
130 return $ env
132 return $ env
131− { _aliases = insert name (Var.local name, tvars, alias') (_aliases env)
133+ { _aliases = insert name (typeVar name, tvars, alias') (_aliases env)
132 , _values = case alias of
134 , _values = case alias of
133− Type.Record _ _ -> insert name (Var.local name) (_values env)
135+ Type.Record _ _ -> insert name (typeVar name) (_values env)
134 _ -> _values env
136 _ -> _values env
135 }
137 }
136 where
138 where
@@ -158,7 +160,7 @@ module' interfaces modul@(Module.Module _ _ exs _ decls) =
158 body :: [D.CanonicalDecl] -> CanonicalBody
160 body :: [D.CanonicalDecl] -> CanonicalBody
159 body decls =
161 body decls =
160 CanonicalBody
162 CanonicalBody
161− { program = Transform.sortDefs . dummyLet $ Transform.toExpr decls
163+ { program = Transform.sortDefs . dummyLet $ Transform.toExpr (Module.getName modul) decls
162 , types = Map.empty
164 , types = Map.empty
163 , datatypes = Map.fromList [ (name,(vars,ctors)) | Datatype name vars ctors <- decls ]
165 , datatypes = Map.fromList [ (name,(vars,ctors)) | Datatype name vars ctors <- decls ]
164 , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
166 , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
@@ -198,6 +200,23 @@ delist fullList (Var.Listing partial open)
198
200
199 _ -> go list xs partial
201 _ -> go list xs partial
200
202
203+filterExports :: Module.Types -> [Var.Value] -> Module.Types
204+filterExports types values =
205+ Map.fromList (concatMap getValue values)
206+ where
207+ getValue :: Var.Value -> [(String, Type.CanonicalType)]
208+ getValue value =
209+ case value of
210+ Var.Value x -> get x
211+ Var.Alias x -> get x
212+ Var.ADT _ (Var.Listing ctors _) -> concatMap get ctors
213+
214+ get :: String -> [(String, Type.CanonicalType)]
215+ get x =
216+ case Map.lookup x types of
217+ Just t -> [(x,t)]
218+ Nothing -> []
219+
201declToValue :: D.ValidDecl -> [Var.Value]
220declToValue :: D.ValidDecl -> [Var.Value]
202declToValue decl =
221declToValue decl =
203 case decl of
222 case decl of