git.iko.soy/elk
on d87affe help sign in
elk/src/Transform/Canonicalize/Environment.hs
91 lines 2.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Environment where
4import Control.Arrow (second)
5import qualified Control.Monad.Error as Error
6import qualified Control.Monad.State as State
7import qualified Data.Map as Map
8import qualified Data.Set as Set
10import AST.Expression.General (saveEnvName)
11import qualified AST.Module as Module
12import qualified AST.Pattern as P
13import qualified AST.Type as Type
14import qualified AST.Variable as Var
16import Text.PrettyPrint (Doc)
19type Dict a = Map.Map String [a]
21dict :: [(String,a)] -> Dict a
22dict pairs =
23 Map.fromList $ map (second (:[])) pairs
25insert :: String -> a -> Dict a -> Dict a
26insert key value =
27 Map.insertWith (++) key [value]
30type Canonicalizer err a =
31 Error.ErrorT err (State.State (Set.Set Module.Name)) a
33uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()
34uses home =
35 Error.lift (State.modify (Set.insert home))
37using :: Var.Canonical -> Canonicalizer String Var.Canonical
38using var@(Var.Canonical home _) =
39 do case home of
40 Var.BuiltIn -> return ()
41 Var.Module path -> uses path
42 Var.Local -> return ()
43 return var
45onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a
46onError handler canonicalizer =
47 do usedModules <- Error.lift State.get
48 let (result, usedModules') =
49 State.runState (Error.runErrorT canonicalizer) usedModules
50 Error.lift (State.put usedModules')
51 case result of
52 Left err -> Error.throwError [handler err]
53 Right x -> return x
56data Environment = Env
57 { _home :: Module.Name
58 , _values :: Dict Var.Canonical
59 , _adts :: Dict Var.Canonical
60 , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)
61 , _patterns :: Dict Var.Canonical
62 }
64builtIns :: Module.Name -> Environment
65builtIns home =
66 Env { _home = home
67 , _values = builtIn (tuples ++ [saveEnvName])
68 , _adts = builtIn (tuples ++ ["List","Int","Float","Char","Bool","String"])
69 , _aliases = dict []
70 , _patterns = builtIn (tuples ++ ["::","[]"])
71 }
72 where
73 builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs
74 tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]
76update :: P.Pattern var -> Environment -> Environment
77update ptrn env =
78 env { _values = foldr put (_values env) (P.boundVarList ptrn) }
79 where
80 put x = Map.insert x [Var.local x]
82merge :: Environment -> Environment -> Environment
83merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)
84 | n1 /= n2 = error "trying to merge incompatable environments"
85 | otherwise =
86 Env { _home = n1
87 , _values = Map.unionWith (++) v1 v2
88 , _adts = Map.unionWith (++) t1 t2
89 , _aliases = Map.unionWith (++) a1 a2
90 , _patterns = Map.unionWith (++) p1 p2
91 }