git.iko.soy/elk
on master help sign in
Add back in checks for duplicate and out-of-order definitions.
93a948cEvan Czaplicki
compiler/Initialize.hs+3−3
compare with master
unifiedsplit
@@ -10,6 +10,7 @@ import Data.List (intercalate,partition)
10import Parse.Parser (parseProgram, parseDependencies)
10import Parse.Parser (parseProgram, parseDependencies)
11import qualified Metadata.Libraries as Libs
11import qualified Metadata.Libraries as Libs
12import Transform.Optimize
12import Transform.Optimize
13+import qualified Transform.Check as Check
13import System.Exit
14import System.Exit
14import System.FilePath
15import System.FilePath
15
16
@@ -19,14 +20,13 @@ import Types.Hints (hints)
19import Types.Unify (unify)
20import Types.Unify (unify)
20import Types.Alias (dealias, mistakes)
21import Types.Alias (dealias, mistakes)
21--}
22--}
22−mistakes = undefined
23unify = undefined
23unify = undefined
24hints = undefined
24hints = undefined
25
25
26
26
27checkMistakes :: (Data t, Data v) => Module t v -> Either String (Module t v)
27checkMistakes :: (Data t, Data v) => Module t v -> Either String (Module t v)
28−checkMistakes modul@(Module name ex im stmts) =
28+checkMistakes modul@(Module name ex im decls) =
29− case mistakes stmts of
29+ case Check.mistakes decls of
30 m:ms -> Left (unlines (m:ms))
30 m:ms -> Left (unlines (m:ms))
31 [] -> return modul
31 [] -> return modul
32
32
compiler/SourceSyntax/Expression.hs+4−2
@@ -1,5 +1,7 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
1module SourceSyntax.Expression where
2module SourceSyntax.Expression where
2
3
4+import Data.Data
3import Data.List (intercalate)
5import Data.List (intercalate)
4import qualified Text.Pandoc as Pandoc
6import qualified Text.Pandoc as Pandoc
5import SourceSyntax.PrettyPrint
7import SourceSyntax.PrettyPrint
@@ -29,12 +31,12 @@ data Expr t v
29 | Modify (LExpr t v) [(String, LExpr t v)]
31 | Modify (LExpr t v) [(String, LExpr t v)]
30 | Record [(String, LExpr t v)]
32 | Record [(String, LExpr t v)]
31 | Markdown Pandoc.Pandoc
33 | Markdown Pandoc.Pandoc
32− deriving (Eq, Show)
34+ deriving (Eq, Show, Data, Typeable)
33
35
34data Def tipe var
36data Def tipe var
35 = Def Pattern.Pattern (LExpr tipe var)
37 = Def Pattern.Pattern (LExpr tipe var)
36 | TypeAnnotation String Type.Type
38 | TypeAnnotation String Type.Type
37− deriving (Eq, Show)
39+ deriving (Eq, Show, Data, Typeable)
38
40
39tuple es = Data ("_Tuple" ++ show (length es)) es
41tuple es = Data ("_Tuple" ++ show (length es)) es
40
42
compiler/SourceSyntax/Type.hs+3−2
@@ -1,6 +1,7 @@
1−
1+{-# LANGUAGE DeriveDataTypeable #-}
2module SourceSyntax.Type where
2module SourceSyntax.Type where
3
3
4+import Data.Data
4import qualified Data.Map as Map
5import qualified Data.Map as Map
5import SourceSyntax.PrettyPrint
6import SourceSyntax.PrettyPrint
6import Text.PrettyPrint as P
7import Text.PrettyPrint as P
@@ -10,7 +11,7 @@ data Type = Lambda Type Type
10 | Data String [Type]
11 | Data String [Type]
11 | EmptyRecord
12 | EmptyRecord
12 | Record (Map.Map String [Type]) Type
13 | Record (Map.Map String [Type]) Type
13− deriving (Eq, Show)
14+ deriving (Eq, Show, Data, Typeable)
14
15
15fieldMap :: [(String,Type)] -> Map.Map String [Type]
16fieldMap :: [(String,Type)] -> Map.Map String [Type]
16fieldMap fields =
17fieldMap fields =
compiler/Transform/Check.hsnew file+86
@@ -0,0 +1,86 @@
1+module Transform.Check (mistakes) where
2+
3+import Transform.SortDefinitions (boundVars)
4+import SourceSyntax.Everything
5+import qualified SourceSyntax.Type as T
6+import Data.List as List
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
9+import Data.Data
10+import Data.Generics.Uniplate.Data
11+
12+
13+mistakes :: (Data t, Data v) => [Declaration t v] -> [String]
14+mistakes decls =
15+ concatMap (\defs -> duplicates defs ++ badOrder defs) (getLets decls)
16+
17+
18+getLets :: (Data t, Data v) => [Declaration t v] -> [[Def t v]]
19+getLets decls = defs : concatMap getSubLets defs
20+ where
21+ defs = concatMap (\d -> case d of Definition d -> [d] ; _ -> []) decls
22+
23+ getSubLets def =
24+ case def of
25+ Def pattern expr -> [ defs | Let defs _ <- universeBi expr ]
26+ TypeAnnotation _ _ -> []
27+
28+
29+duplicates :: [Def t v] -> [String]
30+duplicates defs =
31+ map defMsg (dup definition) ++ map annMsg (dup annotation)
32+ where
33+ dup f = map head . filter ((>1) . length) . List.group . List.sort $ concatMap f defs
34+
35+ msg = "Syntax Error: There can only be one "
36+ defMsg x = msg ++ " definition of '" ++ x ++ "'."
37+ annMsg x = msg ++ " type annotation for '" ++ x ++ "'."
38+
39+
40+badOrder :: [Def t v] -> [String]
41+badOrder defs =
42+ map msg $ missings (List.sort $ expectedPairs as ds) (List.sort $ actualPairs defs)
43+ where
44+ msg x = "Syntax Error: The type annotation for '" ++ x ++
45+ "' must be directly above its definition."
46+ as = List.sort $ concatMap annotation defs
47+ ds = List.sort $ concatMap definition defs
48+
49+ expectedPairs :: [String] -> [String] -> [String]
50+ expectedPairs as ds =
51+ case (as,ds) of
52+ (x:xs, y:ys) -> case compare x y of
53+ LT -> expectedPairs xs (y:ys)
54+ EQ -> x : expectedPairs xs ys
55+ GT -> expectedPairs (x:xs) ys
56+ ( _ , _ ) -> []
57+
58+ actualPairs defs =
59+ case defs of
60+ TypeAnnotation name _ : Def (PVar name') _ : rest ->
61+ (if name == name' then [name] else []) ++ actualPairs rest
62+ t:s:rest -> actualPairs (s:rest)
63+ _ -> []
64+
65+ missings :: [String] -> [String] -> [String]
66+ missings expected actual =
67+ case (expected, actual) of
68+ (e:es, a:as) -> case compare e a of
69+ LT -> e : missings es (a:as)
70+ EQ -> missings es as
71+ GT -> a : missings (e:es) as
72+ ( [] , _ ) -> actual
73+ ( _ , [] ) -> expected
74+
75+
76+annotation :: Def t v -> [String]
77+annotation def =
78+ case def of
79+ TypeAnnotation name _ -> [name]
80+ _ -> []
81+
82+definition :: Def t v -> [String]
83+definition def =
84+ case def of
85+ Def pattern _ -> Set.toList (boundVars pattern)
86+ _ -> []