138 lines
4.8 KiB
Haskell
138 lines
4.8 KiB
Haskell
{-# LANGUAGE PatternGuards #-}
|
|
module Types.Alias (dealias, get, mistakes) where
|
|
|
|
import Ast
|
|
import Located
|
|
import Control.Arrow (second)
|
|
import Data.List (group,sort)
|
|
import Data.Maybe (mapMaybe)
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import Types.Substitutions (subst)
|
|
import Types.Types
|
|
import Data.Generics.Uniplate.Data
|
|
|
|
builtins :: [(String,([X],Type))]
|
|
builtins =
|
|
let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
|
|
state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
|
|
line = [("color", tipe "Color"), ("width", float),
|
|
("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
|
|
("miterLimit", float), ("dashing", listOf int),
|
|
("dashOffset", int)]
|
|
makeRecord fields =
|
|
RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
|
|
in [ ("String", ([], listOf char)),
|
|
("Time", ([], float)),
|
|
("KeyCode", ([], int)),
|
|
("Touch", ([], makeRecord touch)),
|
|
("FieldState", ([], makeRecord state)),
|
|
("LineStyle", ([], makeRecord line))
|
|
]
|
|
|
|
get :: [Statement] -> Map.Map String ([X],Type)
|
|
get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
|
|
where getAlias stmt = case stmt of
|
|
TypeAlias alias xs t -> [(alias, (xs,t))]
|
|
_ -> []
|
|
|
|
dealias :: Map.Map String ([X],Type) -> Type -> Type
|
|
dealias aliases t =
|
|
let f = dealias aliases in
|
|
case t of
|
|
ADT name ts -> case Map.lookup name aliases of
|
|
Just (xs,t) -> f (subst (zip xs ts) t)
|
|
Nothing -> ADT name (map f ts)
|
|
LambdaT t u -> LambdaT (f t) (f u)
|
|
RecordT r t -> RecordT (Map.map (map f) r) (f t)
|
|
_ -> t
|
|
|
|
mistakes :: [Statement] -> [String]
|
|
mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
|
|
|
|
badKinds :: [Statement] -> [String]
|
|
badKinds stmts = [msg tname | t <- universeBi stmts, tname <- badT t]
|
|
where
|
|
msg x = "Type Error: Type alias '" ++ x ++
|
|
"' was given the wrong number of arguments."
|
|
|
|
badT :: Type -> [String]
|
|
badT (ADT name ts)
|
|
| Just (xs, _) <- Map.lookup name (get stmts),
|
|
length xs /= length ts = [name]
|
|
badT _ = []
|
|
|
|
annotation :: Def -> Maybe String
|
|
annotation s =
|
|
case s of
|
|
TypeAnnotation name _ -> Just name
|
|
_ -> Nothing
|
|
|
|
definition :: Def -> Maybe String
|
|
definition s =
|
|
case s of
|
|
FnDef name _ _ -> Just name
|
|
OpDef name _ _ _ -> Just name
|
|
_ -> Nothing
|
|
|
|
checkTopLevelAndLets :: [Statement] -> (String -> [Def] -> [a]) -> [a]
|
|
checkTopLevelAndLets stmts fcheck =
|
|
fcheck "at top-level" topLevelDefs ++
|
|
concatMap (fcheck "in let binding") allLetDefs
|
|
where
|
|
topLevelDefs = mapMaybe maybeDef stmts
|
|
maybeDef (Definition d) = Just d
|
|
maybeDef _ = Nothing
|
|
allLetDefs = [defList | Let defList _ <- universeBi stmts]
|
|
|
|
dups :: [Statement] -> [String]
|
|
dups stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
|
|
let
|
|
dup :: (Def -> Maybe String) -> [String]
|
|
dup f = map head . filter ((>1) . length) . group . sort $ mapMaybe f defs
|
|
|
|
msg = "Syntax Error: There can only be one "
|
|
defMsg x = msg ++ "definition of '" ++ x ++ "' " ++ ctxt ++ "."
|
|
annMsg x = msg ++ "type annotation for '" ++ x ++ "'" ++ ctxt ++ "."
|
|
in
|
|
map defMsg (dup definition) ++ map annMsg (dup annotation)
|
|
|
|
badOrder :: [Statement] -> [String]
|
|
badOrder stmts = checkTopLevelAndLets stmts $ \ctxt defs ->
|
|
let
|
|
msg x = "Syntax Error: The type annotation for '" ++ x ++
|
|
"' must be directly above its definition in " ++ ctxt ++ "."
|
|
as = sort $ mapMaybe annotation defs
|
|
ds = sort $ mapMaybe definition defs
|
|
|
|
expectedPairs :: [String] -> [String] -> [String]
|
|
expectedPairs as ds =
|
|
case (as,ds) of
|
|
(x:xs, y:ys) -> case compare x y of
|
|
LT -> expectedPairs xs (y:ys)
|
|
EQ -> x : expectedPairs xs ys
|
|
GT -> expectedPairs (x:xs) ys
|
|
( _ , _ ) -> []
|
|
|
|
actualPairs :: [Def] -> [String]
|
|
actualPairs stmts =
|
|
case stmts of
|
|
TypeAnnotation n _ : rest@(d : _) ->
|
|
(if Just n == definition d
|
|
then [n]
|
|
else []
|
|
) ++ actualPairs rest
|
|
t:s:rest -> actualPairs (s:rest)
|
|
_ -> []
|
|
|
|
missings :: [String] -> [String] -> [String]
|
|
missings expected actual =
|
|
case (expected, actual) of
|
|
(e:es, a:as) -> case compare e a of
|
|
LT -> e : missings es (a:as)
|
|
EQ -> missings es as
|
|
GT -> a : missings (e:es) as
|
|
( [] , _ ) -> actual
|
|
( _ , [] ) -> expected
|
|
in
|
|
map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)
|