Merge branch 'scrap-parser-boilerplate' of https://github.com/alekstorm/capnproto

compiler/capnproto-compiler.cabal

@@ -20,7 +20,8 @@ executable capnpc
                    array,
                    data-binary-ieee754,
                    filepath,
-                   directory
+                   directory,
+                   syb
   ghc-options:     -Wall -fno-warn-missing-signatures
   other-modules:
                    Lexer,
@@ -31,5 +32,5 @@ executable capnpc
                    Semantics,
                    Util,
                    CxxGenerator,
+                   JsonGenerator,
                    WireFormat
-

compiler/src/Parser.hs

@@ -23,6 +23,7 @@
 
 module Parser (parseFile) where
 
+import Data.Generics
 import Text.Parsec hiding (tokens)
 import Text.Parsec.Error(newErrorMessage, Message(Message))
 import Token
@@ -72,14 +73,13 @@ located p = do
     t <- p
     return (Located (locatedPos (head input)) t)
 
--- Hmm, boilerplate is not supposed to happen in Haskell.
-matchIdentifier t        = case locatedValue t of { (Identifier        v) -> Just v; _ -> Nothing }
-matchTypeIdentifier t    = case locatedValue t of { (TypeIdentifier    v) -> Just v; _ -> Nothing }
-matchParenthesizedList t = case locatedValue t of { (ParenthesizedList v) -> Just v; _ -> Nothing }
-matchBracketedList t     = case locatedValue t of { (BracketedList     v) -> Just v; _ -> Nothing }
-matchLiteralInt t        = case locatedValue t of { (LiteralInt        v) -> Just v; _ -> Nothing }
-matchLiteralFloat t      = case locatedValue t of { (LiteralFloat      v) -> Just v; _ -> Nothing }
-matchLiteralString t     = case locatedValue t of { (LiteralString     v) -> Just v; _ -> Nothing }
+matchUnary :: (Data a, Data b) => (a -> b) -> Located b -> Maybe a
+matchUnary c t = if toConstr(c undefined) == toConstr(v)
+        then Just $ gmapQi 0 (undefined `mkQ` id) v
+        else Nothing
+    where v = locatedValue t
+matchIdentifier = matchUnary Identifier
+matchTypeIdentifier = matchUnary TypeIdentifier
 matchLiteralBool t = case locatedValue t of
     TrueKeyword -> Just True
     FalseKeyword -> Just False
@@ -98,10 +98,10 @@ anyIdentifier = tokenParser matchIdentifier
             <|> tokenParser matchTypeIdentifier
             <?> "identifier"
 
-literalInt = tokenParser matchLiteralInt <?> "integer"
-literalFloat = tokenParser matchLiteralFloat <?> "floating-point number"
-literalString = tokenParser matchLiteralString <?> "string"
-literalBool = tokenParser matchLiteralBool <?> "boolean"
+literalInt = tokenParser (matchUnary LiteralInt) <?> "integer"
+literalFloat = tokenParser (matchUnary LiteralFloat) <?> "floating-point number"
+literalString = tokenParser (matchUnary LiteralString) <?> "string"
+literalBool = tokenParser (matchLiteralBool) <?> "boolean"
 literalVoid = tokenParser (matchSimpleToken VoidKeyword) <?> "\"void\""
 
 atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
@@ -121,10 +121,10 @@ interfaceKeyword = tokenParser (matchSimpleToken InterfaceKeyword) <?> "\"interf
 optionKeyword = tokenParser (matchSimpleToken OptionKeyword) <?> "\"option\""
 
 parenthesizedList parser = do
-    items <- tokenParser matchParenthesizedList
+    items <- tokenParser (matchUnary ParenthesizedList)
     parseList parser items
 bracketedList parser = do
-    items <- tokenParser matchBracketedList
+    items <- tokenParser (matchUnary BracketedList)
     parseList parser items
 
 declNameBase :: TokenParser DeclName

compiler/src/Token.hs

@@ -21,12 +21,15 @@
 -- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module Token where
 
+import Data.Generics
 import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
 import Text.Printf (printf)
 
-data Located t = Located { locatedPos :: SourcePos, locatedValue :: t }
+data Located t = Located { locatedPos :: SourcePos, locatedValue :: t } deriving (Typeable, Data)
 
 instance Show t => Show (Located t) where
     show (Located pos x) = printf "%d:%d:%s" (sourceLine pos) (sourceColumn pos) (show x)
@@ -37,7 +40,7 @@ instance Eq a => Eq (Located a) where
 instance Ord a => Ord (Located a) where
     compare (Located _ a) (Located _ b) = compare a b
 
-data TokenSequence = TokenSequence [Located Token] SourcePos deriving(Show, Eq)
+data TokenSequence = TokenSequence [Located Token] SourcePos deriving(Data, Typeable, Show, Eq)
 
 data Token = Identifier String
            | TypeIdentifier String
@@ -69,7 +72,7 @@ data Token = Identifier String
            | UnionKeyword
            | InterfaceKeyword
            | OptionKeyword
-           deriving (Show, Eq)
+           deriving (Data, Typeable, Show, Eq)
 
 data Statement = Line TokenSequence
                | Block TokenSequence [Located Statement]