git.iko.soy/elk
on d87affe help sign in
elk/src/Transform/Canonicalize/Type.hs
71 lines 2.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Type (tipe) where
4import Control.Arrow (second)
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad.Error
7import qualified Data.Map as Map
8import Data.Traversable (traverse)
10import qualified AST.Type as T
11import qualified AST.Variable as Var
13import Transform.Canonicalize.Environment
14import qualified Transform.Canonicalize.Variable as Canonicalize
16tipe :: Environment -> T.RawType -> Canonicalizer String T.CanonicalType
17tipe env typ =
18 let go = tipe env in
19 case typ of
20 T.Var x -> return (T.Var x)
21 T.Type _ -> canonicalizeApp env typ []
22 T.App t ts -> canonicalizeApp env t ts
24 T.Lambda a b -> T.Lambda <$> go a <*> go b
25 T.Aliased name t -> T.Aliased name <$> go t
27 T.Record fields ext ->
28 let go' (f,t) = (,) f <$> go t
29 in T.Record <$> mapM go' fields <*> traverse go ext
31canonicalizeApp :: Environment -> T.RawType -> [T.RawType]
32 -> Canonicalizer String T.CanonicalType
33canonicalizeApp env f args =
34 case f of
35 T.Type (Var.Raw rawName) ->
36 do answer <- Canonicalize.tvar env rawName
37 case answer of
38 Right alias -> canonicalizeAlias env alias args
39 Left name -> case args of
40 [] -> return (T.Type name)
41 _:_ -> T.App (T.Type name) <$> mapM (tipe env) args
43 _ -> T.App <$> tipe env f <*> mapM (tipe env) args
45canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)
46 -> [T.RawType]
47 -> Canonicalizer String T.CanonicalType
48canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
49 do when (tipesLen /= tvarsLen) (throwError msg)
50 tipes' <- mapM (tipe env) tipes
51 let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe
52 return $ T.Aliased name tipe'
53 where
54 tipesLen = length tipes
55 tvarsLen = length tvars
57 msg :: String
58 msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++
59 " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
60 " but was given " ++ show tipesLen
62 replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType
63 replace typeTable t =
64 let go = replace typeTable in
65 case t of
66 T.Lambda a b -> T.Lambda (go a) (go b)
67 T.Var x -> Map.findWithDefault t x typeTable
68 T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)
69 T.Aliased original t' -> T.Aliased original (go t')
70 T.Type _ -> t
71 T.App f args -> T.App (go f) (map go args)