git.iko.soy/elk
on master help sign in
Get Parse.Declaration working
f908dc8Evan Czaplicki
src/AST/Declaration.hs+7−6
compare with master
unifiedsplit
@@ -2,6 +2,7 @@
2module AST.Declaration where
2module AST.Declaration where
3
3
4import Data.Binary
4import Data.Binary
5+import Data.Text (Text)
5
6
6import qualified AST.Expression.Canonical as Canonical
7import qualified AST.Expression.Canonical as Canonical
7import qualified AST.Expression.Source as Src
8import qualified AST.Expression.Source as Src
@@ -18,7 +19,7 @@ type Source =
18
19
19
20
20data CommentOr a
21data CommentOr a
21− = Comment (A.Located String)
22+ = Comment (A.Located Text)
22 | Whatever a
23 | Whatever a
23
24
24
25
@@ -27,7 +28,7 @@ data Raw
27 | Union (Union Type.Raw)
28 | Union (Union Type.Raw)
28 | Alias (Alias Type.Raw)
29 | Alias (Alias Type.Raw)
29 | Fixity Infix
30 | Fixity Infix
30− | Port String Type.Raw
31+ | Port Text Type.Raw
31
32
32
33
33
34
@@ -77,14 +78,14 @@ addInfix fixity decls =
77
78
78data Type body =
79data Type body =
79 Type
80 Type
80− { _name :: String
81+ { _name :: Text
81− , _args :: [String]
82+ , _args :: [Text]
82 , _body :: body
83 , _body :: body
83 }
84 }
84
85
85
86
86type Union tipe =
87type Union tipe =
87− Type [(String, [tipe])]
88+ Type [(Text, [tipe])]
88
89
89
90
90type Alias tipe =
91type Alias tipe =
@@ -97,7 +98,7 @@ type Alias tipe =
97
98
98data Infix =
99data Infix =
99 Infix
100 Infix
100− { _op :: String
101+ { _op :: Text
101 , _associativity :: Assoc
102 , _associativity :: Assoc
102 , _precedence :: Int
103 , _precedence :: Int
103 }
104 }
src/Parse/Declaration.hs+111−60
@@ -1,100 +1,151 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2+{-# LANGUAGE OverloadedStrings #-}
2module Parse.Declaration where
3module Parse.Declaration where
3
4
4−import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )
5+import Data.Text (Text)
5
6
6import qualified AST.Declaration as Decl
7import qualified AST.Declaration as Decl
7−import qualified Parse.Binop as Binop
8+import qualified AST.Type as Type
8import qualified Parse.Expression as Expr
9import qualified Parse.Expression as Expr
9import Parse.Helpers as Help
10import Parse.Helpers as Help
10import qualified Parse.Type as Type
11import qualified Parse.Type as Type
12+import qualified Reporting.Annotation as A
13+import qualified Reporting.Region as R
11
14
12
15
13
16
17+-- DECLARATION
18+
19+
14−declaration :: IParser Decl.Source
20+declaration :: SParser Decl.Source
15declaration =
21declaration =
16− commentOr $ addLocation $
22+ do start <- getPosition
17− choice
23+ oneOf
24+ [ docDecl start
18− [ typeDecl
25+ , typeDecl start
19− , infixDecl
26+ , infixDecl start
20− , portDecl
27+ , portDecl start
21− , definition
28+ , defDecl start
22− ]
29+ ]
23−
30+
24−
31+
25−commentOr :: IParser a -> IParser (Decl.CommentOr a)
32+
26−commentOr parser =
33+-- DOC COMMENTS
27− choice
34+
28− [ Decl.Comment <$> addLocation Help.docComment
29− , Decl.Whatever <$> parser
30− ]
31
35
36+docDecl :: R.Position -> SParser Decl.Source
37+docDecl start =
38+ do comment <- docComment
39+ end <- getPosition
40+ space <- whitespace
41+ return ( Decl.Comment (A.at start end comment), end, space )
32
42
33
43
34-- TYPE ANNOTATIONS and DEFINITIONS
44-- TYPE ANNOTATIONS and DEFINITIONS
35
45
36
46
37−definition :: IParser Decl.Raw
47+defDecl :: R.Position -> SParser Decl.Source
38−definition =
48+defDecl start =
39− do def <- Expr.def <?> "a definition or type annotation"
49+ do (def, end, space) <- Expr.definition
40− return $ Decl.Def def
50+ let decl = A.at start end (Decl.Def def)
51+ return ( Decl.Whatever decl, end, space )
41
52
42
53
43
54
44-- TYPE ALIAS and UNION TYPES
55-- TYPE ALIAS and UNION TYPES
45
56
46
57
47−typeDecl :: IParser Decl.Raw
58+typeDecl :: R.Position -> SParser Decl.Source
48−typeDecl =
59+typeDecl start =
49− do try (reserved "type") <?> "a type declaration"
60+ do keyword "type"
50− forcedWS
61+ spaces
51− isAlias <- optionMaybe (string "alias" >> forcedWS)
62+ oneOf
52−
63+ [ do keyword "alias"
64+ spaces
65+ (name, args) <- nameArgsEquals
66+ (tipe, end, space) <- Type.expression
67+ let decl = A.at start end (Decl.Alias (Decl.Type name args tipe))
68+ return ( Decl.Whatever decl, end, space )
69+ , do (name, args) <- nameArgsEquals
70+ (firstCtor, firstEnd, firstSpace) <- Type.unionConstructor
71+ (ctors, end, space) <- chompConstructors [firstCtor] firstEnd firstSpace
72+ let decl = A.at start end (Decl.Union (Decl.Type name args ctors))
73+ return ( Decl.Whatever decl, end, space )
74+ ]
75+
76+
77+nameArgsEquals :: Parser (Text, [Text])
78+nameArgsEquals =
53− name <- capVar
79+ do name <- capVar
54− args <- spacePrefix lowVar
80+ spaces
81+ nameArgsEqualsHelp name []
82+
83+
84+nameArgsEqualsHelp :: Text -> [Text] -> Parser (Text, [Text])
85+nameArgsEqualsHelp name args =
86+ oneOf
87+ [ do arg <- lowVar
88+ spaces
89+ nameArgsEqualsHelp name (arg:args)
55− padded equals
90+ , do equals
91+ spaces
92+ return ( name, reverse args )
93+ ]
56
94
57− case isAlias of
58− Just _ ->
59− do tipe <- Type.expr <?> "a type"
60− return $ Decl.Alias (Decl.Type name args tipe)
61
95
62− Nothing ->
96+chompConstructors :: [(Text, [Type.Raw])] -> R.Position -> Space -> SParser [(Text, [Type.Raw])]
63− do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
97+chompConstructors ctors end space =
64− return $ Decl.Union (Decl.Type name args tcs)
98+ oneOf
99+ [ do checkSpaces space
100+ pipe
101+ spaces
102+ (ctor, newEnd, newSpace) <- Type.unionConstructor
103+ chompConstructors (ctor:ctors) newEnd newSpace
104+ , return ( reverse ctors, end, space )
105+ ]
65
106
66
107
67
108
68-- INFIX
109-- INFIX
69
110
70
111
71−infixDecl :: IParser Decl.Raw
112+infixDecl :: R.Position -> SParser Decl.Source
72−infixDecl =
113+infixDecl start =
73− expecting "an infix declaration" $
114+ oneOf
74− do assoc <-
115+ [ do keyword "infixl"
75− choice
116+ infixDeclHelp start Decl.L
76− [ try (reserved "infixl") >> return Decl.L
117+ , do keyword "infixr"
77− , try (reserved "infixr") >> return Decl.R
118+ infixDeclHelp start Decl.R
78− , try (reserved "infix") >> return Decl.N
119+ , do keyword "infix"
120+ infixDeclHelp start Decl.N
79− ]
121+ ]
80− forcedWS
122+
123+
124+infixDeclHelp :: R.Position -> Decl.Assoc -> SParser Decl.Source
125+infixDeclHelp start assoc =
126+ do spaces
81 n <- digit
127 n <- digit
82− forcedWS
128+ spaces
83− op <- Binop.infixOp
129+ op <- infixOp
130+ end <- getPosition
131+ space <- whitespace
84− return $ Decl.Fixity (Decl.Infix op assoc (read [n]))
132+ let decl = A.at start end (Decl.Fixity (Decl.Infix op assoc n))
133+ return ( Decl.Whatever decl, end, space )
85
134
86
135
87
136
88-- FOREIGN
137-- FOREIGN
89
138
90
139
91−portDecl :: IParser Decl.Raw
140+portDecl :: R.Position -> SParser Decl.Source
92−portDecl =
141+portDecl start =
93− expecting "a port declaration" $
94− do try (reserved "port")
142+ do keyword "port"
95− forcedWS
143+ spaces
96− name <- Help.lowVar
144+ name <- lowVar
145+ spaces
97− padded hasType
146+ hasType
147+ spaces
98− tipe <- Type.expr
148+ (tipe, end, space) <- Type.expression
99− return $ Decl.Port name tipe
149+ let decl = A.at start end (Decl.Port name tipe)
150+ return ( Decl.Whatever decl, end, space )
100
151
src/Parse/Primitives.hs+64−6
@@ -10,7 +10,9 @@ module Parse.Primitives
10 , getPosition, getCol
10 , getPosition, getCol
11 , getIndent, setIndent
11 , getIndent, setIndent
12 , Space(..), whitespace
12 , Space(..), whitespace
13+ , docComment
13 , string, character
14 , string, character
15+ , digit
14 )
16 )
15 where
17 where
16
18
@@ -557,15 +559,20 @@ eatLineCommentHelp array offset length row col =
557
559
558eatMultiComment :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
560eatMultiComment :: Text.Array -> Int -> Int -> Int -> Int -> Either Error ( Int, Int, Int, Int )
559eatMultiComment array offset length row col =
561eatMultiComment array offset length row col =
560− if length == 1 then
562+ if length <= 2 then
561 Right ( offset, length, row, col )
563 Right ( offset, length, row, col )
562
564
563 else
565 else
566+ let
564− case Text.unsafeIndex array (offset + 1) of
567+ !yesDash = Text.unsafeIndex array (offset + 1) == 0x002D {- - -}
565− 0x002D {- - -} ->
568+ !noBar = Text.unsafeIndex array (offset + 2) /= 0x007C {- | -}
569+ in
570+ if yesDash && noBar then
571+ do (newOffset, newLength, newRow, newCol) <-
566− eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) 1
572+ eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) 1
573+ eatSpaces array newOffset newLength newRow newCol
567
574
568− _ ->
575+ else
569 Right ( offset, length, row, col )
576 Right ( offset, length, row, col )
570
577
571
578
@@ -585,7 +592,7 @@ eatMultiCommentHelp array offset length row col openComments =
585 else if word == 0x002D {- - -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x007D {- } -} then
592 else if word == 0x002D {- - -} && length > 1 && Text.unsafeIndex array (offset + 1) == 0x007D {- } -} then
586
593
587 if openComments == 1 then
594 if openComments == 1 then
588− eatSpaces array (offset + 2) (length - 2) row (col + 2)
595+ Right ( offset + 2, length - 2, row, col + 2 )
589 else
596 else
590 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments - 1)
597 eatMultiCommentHelp array (offset + 2) (length - 2) row (col + 2) (openComments - 1)
591
598
@@ -603,6 +610,34 @@ eatMultiCommentHelp array offset length row col openComments =
603
610
604
611
605
612
613+-- DOCUMENTATION COMMENT
614+
615+
616+docComment :: Parser Text
617+docComment =
618+ do text "{-|"
619+ Parser $ \(State array offset length indent row col) cok cerr _ _ ->
620+ case eatMultiCommentHelp array offset length row col 1 of
621+ Left err ->
622+ cerr err
623+
624+ Right (newOffset, newLength, newRow, newCol) ->
625+ let
626+ !newSize =
627+ newOffset - offset
628+
629+ makeArray =
630+ do mutableArray <- Text.new newSize
631+ Text.copyI mutableArray 0 array offset newSize
632+ return mutableArray
633+
634+ comment =
635+ Text.Text (Text.run makeArray) 0 newSize
636+ in
637+ cok comment (State array newOffset newLength indent newRow newCol)
638+
639+
640+
606-- STRINGS
641-- STRINGS
607
642
608
643
@@ -788,3 +823,26 @@ characterHelp array offset length row col =
788
823
789 else
824 else
790 Left (Error row col)
825 Left (Error row col)
826+
827+
828+
829+-- NUMBERS
830+
831+
832+digit :: Parser Int
833+digit =
834+ Parser $ \(State array offset length indent row col) cok _ _ eerr ->
835+ if length == 0 then
836+ eerr (Error row col)
837+
838+ else
839+ let
840+ !word = Text.unsafeIndex array offset
841+ !isDigit = word <= 0x0039 {- 9 -} && word >= 0x0030 {- 0 -}
842+ in
843+ if isDigit then
844+ cok
845+ (fromIntegral (word - 0x0030))
846+ (State array (offset + 1) (length - 1) indent row (col + 1))
847+ else
848+ eerr (Error row col)
src/Parse/Type.hs+33−21
@@ -1,6 +1,6 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3−module Parse.Type (expression) where
3+module Parse.Type (expression, unionConstructor) where
4
4
5import Data.Text (Text)
5import Data.Text (Text)
6
6
@@ -59,15 +59,7 @@ expression =
59
59
60
60
61
61
62−-- TYPE APPLICATION
62+-- TYPE CONSTRUCTORS
63−
64−
65−app :: R.Position -> SParser Type.Raw
66−app start =
67− do ctor <- constructor
68− end <- getPosition
69− space <- whitespace
70− appHelp ctor [] start end space
71
63
72
64
73constructor :: Parser Type.Raw
65constructor :: Parser Type.Raw
@@ -76,22 +68,42 @@ constructor =
76 fmap (Type.RType . Var.Raw) qualifiedCapVar
68 fmap (Type.RType . Var.Raw) qualifiedCapVar
77
69
78
70
71+app :: R.Position -> SParser Type.Raw
72+app start =
73+ do ctor <- constructor
74+ ctorEnd <- getPosition
75+ ctorSpace <- whitespace
76+ (args, end, space) <- eatArgs [] ctorEnd ctorSpace
77+ case args of
78+ [] ->
79+ return ( ctor, end, space )
80+
81+ _ ->
82+ let
83+ tipe =
84+ A.at start end (Type.RApp ctor (reverse args))
85+ in
86+ return ( tipe, end, space )
87+
88+
89+unionConstructor :: SParser (Text, [Type.Raw])
90+unionConstructor =
91+ do ctor <- capVar
92+ ctorEnd <- getPosition
93+ ctorSpace <- whitespace
94+ (args, end, space) <- eatArgs [] ctorEnd ctorSpace
95+ return ( (ctor, args), end, space )
96+
97+
79−appHelp :: Type.Raw -> [Type.Raw] -> R.Position -> R.Position -> Space -> SParser Type.Raw
98+eatArgs :: [Type.Raw] -> R.Position -> Space -> SParser [Type.Raw]
80−appHelp ctor args start end space =
99+eatArgs args end space =
81 oneOf
100 oneOf
82 [ do checkSpaces space
101 [ do checkSpaces space
83 arg <- term
102 arg <- term
84 newEnd <- getPosition
103 newEnd <- getPosition
85 newSpace <- whitespace
104 newSpace <- whitespace
86− appHelp ctor (arg:args) start newEnd newSpace
105+ eatArgs (arg:args) newEnd newSpace
87− , let
88− tipe =
89− if null args then
90− ctor
91− else
92− A.at start end (Type.RApp ctor (reverse args))
93− in
94− return ( tipe, end, space )
106+ , return ( reverse args, end, space )
95 ]
107 ]
96
108
97
109