git.iko.soy/elk
on 501c607 help sign in
elk/src/Transform/Canonicalize/Type.hs
84 lines 2.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Type (tipe) where
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad.Error
6import Data.Traversable (traverse)
8import qualified AST.Type as T
9import qualified AST.Variable as Var
11import Transform.Canonicalize.Environment
12import qualified Transform.Canonicalize.Variable as Canonicalize
15tipe
16 :: Environment
17 -> T.RawType
18 -> Canonicalizer String T.CanonicalType
19tipe env typ =
20 let go = tipe env
21 goSnd (name,t) =
22 (,) name <$> go t
23 in
24 case typ of
25 T.Var x ->
26 return (T.Var x)
28 T.Type _ ->
29 canonicalizeApp env typ []
31 T.App t ts ->
32 canonicalizeApp env t ts
34 T.Lambda a b ->
35 T.Lambda <$> go a <*> go b
37 T.Aliased name args t ->
38 T.Aliased name <$> mapM goSnd args <*> go t
40 T.Record fields ext ->
41 T.Record <$> mapM goSnd fields <*> traverse go ext
44canonicalizeApp
45 :: Environment
46 -> T.RawType
47 -> [T.RawType]
48 -> Canonicalizer String T.CanonicalType
49canonicalizeApp env f args =
50 case f of
51 T.Type (Var.Raw rawName) ->
52 do answer <- Canonicalize.tvar env rawName
53 case answer of
54 Right alias ->
55 canonicalizeAlias env alias args
57 Left name ->
58 case args of
59 [] -> return (T.Type name)
60 _ ->
61 T.App (T.Type name) <$> mapM (tipe env) args
63 _ ->
64 T.App <$> tipe env f <*> mapM (tipe env) args
67canonicalizeAlias
68 :: Environment
69 -> (Var.Canonical, [String], T.CanonicalType)
70 -> [T.RawType]
71 -> Canonicalizer String T.CanonicalType
72canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
73 do when (tipesLen /= tvarsLen) (throwError msg)
74 tipes' <- mapM (tipe env) tipes
75 return $ T.Aliased name (zip tvars tipes') dealiasedTipe
76 where
77 tipesLen = length tipes
78 tvarsLen = length tvars
80 msg :: String
81 msg =
82 "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++
83 " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
84 " but was given " ++ show tipesLen