ddc-base (empty) → 0.2.0.1
raw patch · 6 files changed
+334/−0 lines, 6 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, transformers, wl-pprint
Files
- DDC/Base/Lexer.hs +49/−0
- DDC/Base/Parser.hs +107/−0
- DDC/Base/Pretty.hs +116/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- ddc-base.cabal +40/−0
+ DDC/Base/Lexer.hs view
@@ -0,0 +1,49 @@++-- | Lexer utilities.+module DDC.Base.Lexer+ ( SourcePos (..)+ + -- * Tokens+ , Token (..)+ , takeParsecSourcePos)+where+import DDC.Base.Pretty+import qualified Text.Parsec.Pos as P+++-- SourcePos ------------------------------------------------------------------+-- | A position in the source file. +--+-- If there is no file path then we assume that the input has been read+-- from an interactive session and display ''<interactive>'' when pretty printing.+data SourcePos + = SourcePos+ { sourcePosFile :: Maybe FilePath+ , sourcePosLine :: Int+ , sourcePosColumn :: Int }+ deriving (Eq, Show)+++instance Pretty SourcePos where+ ppr (SourcePos (Just f) l c) + = ppr $ f ++ ":" ++ show l ++ ":" ++ show c++ ppr (SourcePos Nothing l c) + = ppr $ "<interactive>:" ++ show l ++ ":" ++ show c+++-- Token-----------------------------------------------------------------------+-- | Wrapper for primitive token type that gives it a source position.+data Token t+ = Token+ { tokenTok :: t+ , tokenSourcePos :: SourcePos }+ deriving (Eq, Show)+++-- | Take the parsec style source position from a token.+takeParsecSourcePos :: Token k -> P.SourcePos+takeParsecSourcePos (Token _ sp)+ = case sp of+ SourcePos Nothing l c -> P.newPos "<interactive>" l c+ SourcePos (Just f) l c -> P.newPos f l c
+ DDC/Base/Parser.hs view
@@ -0,0 +1,107 @@++-- | Parser utilities.+module DDC.Base.Parser+ ( module Text.Parsec+ , Parser+ , ParserState (..)+ , runTokenParser+ , pTokMaybe+ , pTokAs+ , pTok)+where+import DDC.Base.Lexer+import DDC.Base.Pretty+import Data.Functor.Identity+import Text.Parsec+import Text.Parsec as P+import Text.Parsec.Error as P+++-- | A generic parser,+-- parameterised over token and return types.+type Parser k a+ = Eq k+ => P.ParsecT [Token k] (ParserState k) Identity a+++-- | A parser state that keeps track of the name of the source file.+data ParserState k+ = ParseState+ { stateTokenShow :: k -> String+ , stateFileName :: String }+++-- | Run a generic parser.+runTokenParser+ :: Eq k+ => (k -> String) -- ^ Show a token.+ -> String -- ^ File name for error messages.+ -> Parser k a -- ^ Parser to run.+ -> [Token k] -- ^ Tokens to parse.+ -> Either P.ParseError a++runTokenParser tokenShow fileName parser + = P.runParser parser+ ParseState + { stateTokenShow = tokenShow+ , stateFileName = fileName }+ fileName+++-------------------------------------------------------------------------------+-- | Accept the given token.+pTok :: Eq k => k -> Parser k ()+pTok k = pTokMaybe $ \k' -> if k == k' then Just () else Nothing+++-- | Accept a token and return the given value.+pTokAs :: Eq k => k -> t -> Parser k t+pTokAs k t = pTok k >> return t+++-- | Accept a token if the function returns `Just`. +pTokMaybe :: (k -> Maybe a) -> Parser k a+pTokMaybe f+ = do state <- P.getState+ P.token (stateTokenShow state . tokenTok)+ (takeParsecSourcePos)+ (f . tokenTok)+++-------------------------------------------------------------------------------+instance Pretty P.ParseError where+ ppr err+ = vcat $ [ text "Parse error in" <+> text (show (P.errorPos err)) ]+ ++ (map ppr $ packMessages $ P.errorMessages err)+ + +instance Pretty P.Message where+ ppr msg+ = case msg of+ SysUnExpect str -> text "Unexpected" <+> text str <> text "."+ UnExpect str -> text "Unexpected" <+> text str <> text "."+ Expect str -> text "Expected" <+> text str <> text "."+ Message str -> text str+++-- | When we get a parse error, parsec adds multiple 'Unexpected' messages,+-- but we only want to display the first one.+packMessages :: [P.Message] -> [P.Message]+packMessages mm+ = case mm of+ [] -> []+ m1@(P.UnExpect _) : (P.UnExpect _) : rest+ -> packMessages (m1 : rest)++ m1@(P.SysUnExpect _) : (P.SysUnExpect _) : rest+ -> packMessages (m1 : rest)++ m1@(P.SysUnExpect _) : (P.UnExpect _) : rest+ -> packMessages (m1 : rest)++ m1@(P.UnExpect _) : (P.SysUnExpect _) : rest+ -> packMessages (m1 : rest)++ m1 : rest+ -> m1 : packMessages rest+
+ DDC/Base/Pretty.hs view
@@ -0,0 +1,116 @@++-- | Pretty printer utilities.+--+-- This is a re-export of Daan Leijen's pretty printer package (@wl-pprint@),+-- but with a `Pretty` class that includes a `pprPrec` function.+module DDC.Base.Pretty+ ( module Text.PrettyPrint.Leijen+ , Pretty(..)+ , pprParen++ -- * Rendering+ , RenderMode (..)+ , render+ , renderPlain+ , renderIndent+ , putDoc, putDocLn)+where+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Text.PrettyPrint.Leijen as P+import Text.PrettyPrint.Leijen + hiding (Pretty(..), renderPretty, putDoc)+++-- Utils ---------------------------------------------------------------------+-- | Wrap a `Doc` in parens if the predicate is true.+pprParen :: Bool -> Doc -> Doc+pprParen b c+ = if b then parens c+ else c++-- Pretty Class --------------------------------------------------------------+class Pretty a where+ ppr :: a -> Doc+ ppr = pprPrec 0 ++ pprPrec :: Int -> a -> Doc+ pprPrec _ = ppr+++instance Pretty Bool where+ ppr = text . show++instance Pretty Int where+ ppr = text . show++instance Pretty Char where+ ppr = text . show++instance Pretty a => Pretty [a] where+ ppr xs = encloseSep lbracket rbracket comma + $ map ppr xs++instance Pretty a => Pretty (Set a) where+ ppr xs = encloseSep lbracket rbracket comma + $ map ppr $ Set.toList xs++instance (Pretty a, Pretty b) => Pretty (a, b) where+ ppr (a, b) = parens $ ppr a <> comma <> ppr b+++-- Rendering ------------------------------------------------------------------+-- | How to pretty print a doc.+data RenderMode+ -- | Render the doc with indenting.+ = RenderPlain++ -- | Render the doc without indenting.+ | RenderIndent+ deriving (Eq, Show)+++-- | Render a doc with the given mode.+render :: RenderMode -> Doc -> String+render mode doc+ = case mode of+ RenderPlain -> eatSpace True $ displayS (renderCompact doc) ""+ RenderIndent -> displayS (P.renderPretty 0.8 100000 doc) ""++ where eatSpace :: Bool -> String -> String+ eatSpace _ [] = []+ eatSpace True (c:cs)+ = case c of+ ' ' -> eatSpace True cs+ '\n' -> eatSpace True cs+ _ -> c : eatSpace False cs++ eatSpace False (c:cs)+ = case c of+ ' ' -> ' ' : eatSpace True cs+ '\n' -> ' ' : eatSpace True cs+ _ -> c : eatSpace False cs+++-- | Convert a `Doc` to a string without indentation.+renderPlain :: Doc -> String+renderPlain = render RenderPlain+++-- | Convert a `Doc` to a string with indentation+renderIndent :: Doc -> String+renderIndent = render RenderIndent+++-- | Put a `Doc` to `stdout` using the given mode.+putDoc :: RenderMode -> Doc -> IO ()+putDoc mode doc+ = putStr $ render mode doc++-- | Put a `Doc` to `stdout` using the given mode.+putDocLn :: RenderMode -> Doc -> IO ()+putDocLn mode doc+ = putStrLn $ render mode doc+++
+ LICENSE view
@@ -0,0 +1,20 @@+--------------------------------------------------------------------------------+The Disciplined Disciple Compiler License (MIT style)++Copyright (c) 2008-2011 Benjamin Lippmeier++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++--------------------------------------------------------------------------------+Redistributions of libraries in ./external are governed by their own licenses:++ - TinyPTC GNU Lesser General Public License+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ddc-base.cabal view
@@ -0,0 +1,40 @@+Name: ddc-base+Version: 0.2.0.1+License: MIT+License-file: LICENSE+Author: Ben Lippmeier+Maintainer: benl@ouroborus.net+Build-Type: Simple+Cabal-Version: >=1.6+Stability: experimental+Category: Compilers/Interpreters+Homepage: http://disciple.ouroborus.net+Bug-reports: disciple@ouroborus.net+Synopsis: Disciple Core language common utilities. +Description:+ This package re-exports the main external dependencies of + the Disciplined Disciple Compiler project.++Library+ Build-Depends: + base == 4.5.*,+ transformers == 0.2.*,+ containers == 0.4.*,+ wl-pprint == 1.1.*,+ parsec == 3.1.*++ Exposed-modules:+ DDC.Base.Lexer+ DDC.Base.Parser+ DDC.Base.Pretty+ + GHC-options:+ -Wall+ -fno-warn-orphans++ Extensions:+ ParallelListComp+ PatternGuards+ RankNTypes+ FlexibleContexts+ KindSignatures