git.iko.soy/elk
on 00a3069 help sign in
elk/src/Canonicalize/Type.hs
150 lines 3.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Type
4 ( toAnnotation
5 , canonicalize
6 )
7 where
10import qualified Data.List as List
11import qualified Data.Map as Map
13import qualified AST.Canonical as Can
14import qualified AST.Source as Src
15import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment.Dups as Dups
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Region as R
21import qualified Reporting.Result as Result
25-- RESULT
28type Result i w a =
29 Result.Result i w Error.Error a
33-- TO ANNOTATION
36toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation
37toAnnotation env srcType =
38 do tipe <- canonicalize env srcType
39 Result.ok $ Can.Forall (addFreeVars Map.empty tipe) tipe
43-- CANONICALIZE TYPES
46canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type
47canonicalize env (A.At typeRegion tipe) =
48 case tipe of
49 Src.TVar x ->
50 Result.ok (Can.TVar x)
52 Src.TType region name args ->
53 canonicalizeType env typeRegion name args =<<
54 Env.findType region env name
56 Src.TTypeQual region home name args ->
57 canonicalizeType env typeRegion name args =<<
58 Env.findTypeQual region env home name
60 Src.TLambda a b ->
61 Can.TLambda
62 <$> canonicalize env a
63 <*> canonicalize env b
65 Src.TRecord fields ext ->
66 do fieldDict <- Dups.checkFields fields
67 Can.TRecord
68 <$> traverse (canonicalize env) fieldDict
69 <*> traverse (canonicalize env) ext
71 Src.TUnit ->
72 Result.ok Can.TUnit
74 Src.TTuple a b cs ->
75 Can.TTuple
76 <$> canonicalize env a
77 <*> canonicalize env b
78 <*>
79 case cs of
80 [] ->
81 Result.ok Nothing
83 [c] ->
84 Just <$> canonicalize env c
86 _ ->
87 Result.throw $ Error.TupleLargerThanThree typeRegion
91-- CANONICALIZE TYPE
94canonicalizeType :: Env.Env -> R.Region -> N.Name -> [Src.Type] -> Env.Type -> Result i w Can.Type
95canonicalizeType env region name args info =
96 do cargs <- traverse (canonicalize env) args
97 case info of
98 Env.Alias arity home argNames aliasedType ->
99 checkArity arity region name args $
100 Can.TAlias home name (zip argNames cargs) (Can.Holey aliasedType)
102 Env.Union arity home ->
103 checkArity arity region name args $
104 Can.TType home name cargs
107checkArity :: Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer
108checkArity expected region name args answer =
109 let actual = length args in
110 if expected == actual then
111 Result.ok answer
112 else
113 Result.throw (Error.BadArity region Error.TypeArity name expected actual)
117-- ADD FREE VARS
120addFreeVars :: Map.Map N.Name () -> Can.Type -> Map.Map N.Name ()
121addFreeVars freeVars tipe =
122 case tipe of
123 Can.TLambda arg result ->
124 addFreeVars (addFreeVars freeVars result) arg
126 Can.TVar var ->
127 Map.insert var () freeVars
129 Can.TType _ _ args ->
130 List.foldl' addFreeVars freeVars args
132 Can.TRecord fields Nothing ->
133 Map.foldl addFreeVars freeVars fields
135 Can.TRecord fields (Just ext) ->
136 Map.foldl addFreeVars (addFreeVars freeVars ext) fields
138 Can.TUnit ->
139 freeVars
141 Can.TTuple a b maybeC ->
142 case maybeC of
143 Nothing ->
144 addFreeVars (addFreeVars freeVars a) b
146 Just c ->
147 addFreeVars (addFreeVars (addFreeVars freeVars a) b) c
149 Can.TAlias _ _ args _ ->
150 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args