git.iko.soy/elk
on 267f708 help sign in
elk/src/Canonicalize/Environment.hs
160 lines 3.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Environment
3 ( Environment(..)
4 , getPackage
5 , insert
6 , Patch(..), fromPatches, addPattern
7 , builtinPatches
8 , toDealiaser
9 )
10 where
12import qualified Data.List as List
13import qualified Data.Map as Map
14import qualified Data.Maybe as Maybe
15import qualified Data.Set as Set
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Pattern as P
19import qualified AST.Type as Type
20import qualified AST.Variable as Var
21import qualified Elm.Package as Pkg
25-- ENVIRONMENT
28data Environment = Env
29 { _home :: ModuleName.Canonical
30 , _values :: Dict Var.Canonical
31 , _unions :: Dict Var.Canonical
32 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)
33 , _patterns :: Dict (Var.Canonical, Int)
34 }
37type Dict a =
38 Map.Map String (Set.Set a)
41fromPatches :: ModuleName.Canonical -> [Patch] -> Environment
42fromPatches moduleName patches =
43 addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty)
46addPattern :: P.Pattern ann var -> Environment -> Environment
47addPattern pattern env =
48 let
49 patches =
50 map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
51 in
52 addPatches patches env
55getPackage :: Environment -> Pkg.Name
56getPackage env =
57 ModuleName._package (_home env)
61-- PATCHES
64data Patch
65 = Value String Var.Canonical
66 | Union String Var.Canonical
67 | Alias String (Var.Canonical, [String], Type.Canonical)
68 | Pattern String (Var.Canonical, Int)
72-- ADD PATCH TO ENVIRONMENT
75addPatches :: [Patch] -> Environment -> Environment
76addPatches patches env =
77 List.foldl' (flip addPatch) env patches
80addPatch :: Patch -> Environment -> Environment
81addPatch patch env =
82 case patch of
83 Value name var ->
84 env { _values = insert name var (_values env) }
86 Union name var ->
87 env { _unions = insert name var (_unions env) }
89 Alias name var ->
90 env { _aliases = insert name var (_aliases env) }
92 Pattern name var ->
93 env { _patterns = insert name var (_patterns env) }
96insert :: (Ord a) => String -> a -> Dict a -> Dict a
97insert key value =
98 Map.insertWith Set.union key (Set.singleton value)
102-- PATCH HELPERS
105builtinPatches :: [Patch]
106builtinPatches =
107 concat
108 [ map (patch Value) tupleNames
109 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])
110 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])
111 ]
112 where
113 patch mkPatch name =
114 mkPatch name (Var.builtin name)
116 patternPatch (name, args) =
117 Pattern name (Var.builtin name, args)
119 tupleNames =
120 map fst tuples
122 tuples =
123 map toTuple [0..9]
125 toTuple :: Int -> (String, Int)
126 toTuple n =
127 ("_Tuple" ++ show n, n)
131-- TO TYPE DEALIASER
134toDealiaser :: Environment -> Map.Map String String
135toDealiaser (Env _ _ unions aliases _) =
136 let
137 dealiasUnion (localName, canonicalSet) =
138 case Set.toList canonicalSet of
139 [canonicalName] ->
140 Just (Var.toString canonicalName, localName)
141 _ ->
142 Nothing
144 dealiasAlias (localName, canonicalSet) =
145 case Set.toList canonicalSet of
146 [(canonicalName,_,_)] ->
147 Just (Var.toString canonicalName, localName)
148 _ ->
149 Nothing
151 unionPairs =
152 Maybe.mapMaybe dealiasUnion (Map.toList unions)
154 aliasPairs =
155 Maybe.mapMaybe dealiasAlias (Map.toList aliases)
157 add (key,value) dict =
158 Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict
159 in
160 foldr add Map.empty (unionPairs ++ aliasPairs)