ddc-base 0.2.1.2 → 0.4.2.1
raw patch · 14 files changed
Files
- DDC/Base/Env.hs +174/−0
- DDC/Base/Lexer.hs +0/−49
- DDC/Base/Name.hs +22/−0
- DDC/Base/Panic.hs +23/−0
- DDC/Base/Parser.hs +62/−12
- DDC/Base/Pretty.hs +31/−7
- DDC/Control/Monad/Check.hs +73/−0
- DDC/Data/Canned.hs +13/−0
- DDC/Data/ListUtils.hs +75/−0
- DDC/Data/SourcePos.hs +34/−0
- DDC/Data/Token.hs +36/−0
- DDC/Version.hs +8/−0
- LICENSE +1/−15
- ddc-base.cabal +26/−11
+ DDC/Base/Env.hs view
@@ -0,0 +1,174 @@++-- | Generic environment that handles both named and anonymous+-- de-bruijn binders.+module DDC.Base.Env+ ( -- * Types+ Bind (..)+ , Bound (..)+ , Env (..)++ -- * Conversion+ , fromList+ , fromNameList+ , fromNameMap++ -- * Constructors+ , empty+ , singleton+ , extend, extends+ , union, unions++ -- * Lookup+ , member+ , lookup+ , lookupName, lookupIx+ , depth)+where+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map.Strict as Map+import qualified Prelude as P+import Prelude hiding (lookup)+++-------------------------------------------------------------------------------+-- | A binding occurrence of a variable.+data Bind n+ -- | No binding, or alternatively, bind a fresh name that has+ -- no bound uses.+ = BNone++ -- | Anonymous binder.+ | BAnon++ -- | Named binder.+ | BName !n+ deriving (Eq, Ord, Show)+++-- | A bound occurrence of a variable.+data Bound n+ -- | Index an anonymous binder.+ = UIx !Int++ -- | Named variable.+ | UName !n+ deriving (Eq, Ord, Show)+++-- | Generic environment that maps a variable to a thing of type @a@. +data Env n a+ = Env+ { -- | Named things.+ envMap :: !(Map n a)++ -- | Anonymous things.+ , envStack :: ![a] + + -- | Length of the stack.+ , envStackLength :: !Int }+++-------------------------------------------------------------------------------+-- | Convert a list of `Bind`s to an environment.+fromList :: Ord n => [(Bind n, a)] -> Env n a+fromList bs+ = foldr (uncurry extend) empty bs+++-- | Convert a list of `Bind`s to an environment.+fromNameList :: Ord n => [(n, a)] -> Env n a+fromNameList bs+ = foldr (uncurry extend) empty + $ [(BName n, x) | (n, x) <- bs ]+++-- | Convert a map of things to an environment.+fromNameMap :: Map n a -> Env n a+fromNameMap m+ = empty { envMap = m }+++---------------------------------------------------------------------------------+-- | An empty environment, with nothing in it.+empty :: Env n a+empty = Env+ { envMap = Map.empty+ , envStack = [] + , envStackLength = 0 }+++-- | Construct a singleton environment.+singleton :: Ord n => Bind n -> a -> Env n a+singleton b x+ = extend b x empty+++-- | Extend an environment with a new binding.+-- Replaces bindings with the same name already in the environment.+extend :: Ord n => Bind n -> a -> Env n a -> Env n a+extend bb x env+ = case bb of+ BNone{} -> env++ BAnon -> env { envStack = x : envStack env + , envStackLength = envStackLength env + 1 }++ BName n -> env { envMap = Map.insert n x (envMap env) }+++-- | Extend an environment with a list of new bindings.+-- Replaces bindings with the same name already in the environment.+extends :: Ord n => [(Bind n, a)] -> Env n a -> Env n a+extends bs env+ = foldl (flip (uncurry extend)) env bs+++-- | Combine two environments.+-- If both environments have a binding with the same name,+-- then the one in the second environment takes preference.+union :: Ord n => Env n a -> Env n a -> Env n a+union env1 env2+ = Env + { envMap = envMap env1 `Map.union` envMap env2+ , envStack = envStack env2 ++ envStack env1+ , envStackLength = envStackLength env2 + envStackLength env1 }+++-- | Combine multiple environments,+-- with the latter ones taking preference.+unions :: Ord n => [Env n a] -> Env n a+unions envs+ = foldr union empty envs+++-- | Check whether a bound variable is present in an environment.+member :: Ord n => Bound n -> Env n a -> Bool+member uu env+ = isJust $ lookup uu env+++-- | Lookup a bound variable from an environment.+lookup :: Ord n => Bound n -> Env n a -> Maybe a+lookup uu env+ = case uu of+ UIx i -> P.lookup i (zip [0..] (envStack env))+ UName n -> Map.lookup n (envMap env) +++-- | Lookup a value from the environment based on its name.+lookupName :: Ord n => n -> Env n a -> Maybe a+lookupName n env+ = Map.lookup n (envMap env)+++-- | Lookup a value from the environment based on its index.+lookupIx :: Ord n => Int -> Env n a -> Maybe a+lookupIx ix env+ = P.lookup ix (zip [0..] (envStack env))+++-- | Yield the total depth of the anonymous stack.+depth :: Env n a -> Int+depth env = envStackLength env+
− DDC/Base/Lexer.hs
@@ -1,49 +0,0 @@---- | 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/Name.hs view
@@ -0,0 +1,22 @@++module DDC.Base.Name+ ( StringName (..)+ , CompoundName (..))+where++class StringName n where+ -- | Produce a flat string from a name.+ -- The resulting string should be re-lexable as a bindable name.+ stringName :: n -> String+++-- | Compound names can be extended to create new names.+-- This is useful when generating fresh names during program transformation.+class CompoundName n where+ -- | Build a new name based on the given one.+ extendName :: n -> String -> n+ + -- | Split the extension string from a name.+ splitName :: n -> Maybe (n, String)++
+ DDC/Base/Panic.hs view
@@ -0,0 +1,23 @@++module DDC.Base.Panic+ (panic)+where+import DDC.Base.Pretty+++-- | Print an error message and exit the compiler, ungracefully.+--+-- This function should be called when we end up in a state that is definately+-- due to a bug in the compiler. +--+panic :: String -- ^ Package name,+ -> String -- ^ Function name.+ -> Doc -- ^ Error message that makes some suggestion of what+ -- caused the error.+ -> a++panic pkg fun msg+ = error $ renderIndent $ vcat+ [ text "PANIC in" <+> text pkg <> text "." <> text fun + , indent 2 msg + , empty]
DDC/Base/Parser.hs view
@@ -1,19 +1,22 @@+{-# LANGUAGE TypeFamilies #-} -- | Parser utilities. module DDC.Base.Parser ( module Text.Parsec , Parser , ParserState (..)+ , D.SourcePos (..) , runTokenParser- , pTokMaybe- , pTokAs- , pTok)+ , pTokMaybe, pTokMaybeSP+ , pTokAs, pTokAsSP+ , pTok, pTokSP) where-import DDC.Base.Lexer import DDC.Base.Pretty+import DDC.Data.Token+import DDC.Data.SourcePos as D import Data.Functor.Identity-import Text.Parsec-import Text.Parsec as P+import Text.Parsec hiding (SourcePos)+import Text.Parsec as P import Text.Parsec.Error as P @@ -31,7 +34,7 @@ , stateFileName :: String } --- | Run a generic parser.+-- | Run a generic parser, making sure all input is consumed. runTokenParser :: Eq k => (k -> String) -- ^ Show a token.@@ -41,41 +44,88 @@ -> Either P.ParseError a runTokenParser tokenShow fileName parser - = P.runParser parser+ = P.runParser eofParser ParseState { stateTokenShow = tokenShow , stateFileName = fileName } fileName+ where+ eofParser+ = do r <- parser+ -- We can't use primitive Text.Parsec.eof because it requires+ -- @Show (Token k)@+ (do+ c <- pTokMaybe Just+ unexpected (tokenShow c)) <|> return r ------------------------------------------------------------------------------- -- | Accept the given token.-pTok :: Eq k => k -> Parser k ()+pTok :: Eq k => k -> Parser k () pTok k = pTokMaybe $ \k' -> if k == k' then Just () else Nothing +-- | Accept the given token, returning its source position.+pTokSP :: Eq k => k -> Parser k D.SourcePos+pTokSP k + = do (_, sp) <- pTokMaybeSP + $ \k' -> if k == k' then Just () else Nothing+ return sp++ -- | Accept a token and return the given value. pTokAs :: Eq k => k -> t -> Parser k t-pTokAs k t = pTok k >> return t+pTokAs k t + = do pTok k+ return t +-- | Accept a token and return the given value, +-- along with the source position of the token.+pTokAsSP :: Eq k => k -> t -> Parser k (t, D.SourcePos)+pTokAsSP k t + = do sp <- pTokSP k+ return (t, sp)++ -- | Accept a token if the function returns `Just`. -pTokMaybe :: (k -> Maybe a) -> Parser k a-pTokMaybe f+pTokMaybe :: (k -> Maybe a) -> Parser k a+pTokMaybe f = do state <- P.getState+ P.token (stateTokenShow state . tokenTok) (takeParsecSourcePos) (f . tokenTok) +-- | Accept a token if the function return `Just`, +-- also returning the source position of that token.+pTokMaybeSP :: (k -> Maybe a) -> Parser k (a, D.SourcePos)+pTokMaybeSP f+ = do state <- P.getState++ let f' token' + = case f (tokenTok token') of+ Nothing -> Nothing+ Just x -> Just (x, tokenSourcePos token')++ P.token (stateTokenShow state . tokenTok)+ (takeParsecSourcePos)+ f'++ ------------------------------------------------------------------------------- instance Pretty P.ParseError where+ data PrettyMode P.ParseError = PrettyParseError+ pprDefaultMode = PrettyParseError ppr err = vcat $ [ text "Parse error in" <+> text (show (P.errorPos err)) ] ++ (map ppr $ packMessages $ P.errorMessages err) instance Pretty P.Message where+ data PrettyMode P.Message = PrettyMessage+ pprDefaultMode = PrettyMessage ppr msg = case msg of SysUnExpect str -> text "Unexpected" <+> text str <> text "."
DDC/Base/Pretty.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} -- | Pretty printer utilities. --@@ -7,6 +8,7 @@ ( module Text.PrettyPrint.Leijen , Pretty(..) , pprParen+ , padL -- * Rendering , RenderMode (..)@@ -29,23 +31,36 @@ = if b then parens c else c + -- Pretty Class -------------------------------------------------------------- class Pretty a where- ppr :: a -> Doc- ppr = pprPrec 0 + data PrettyMode a + pprDefaultMode :: PrettyMode a+ + ppr :: a -> Doc+ ppr = pprPrec 0 - pprPrec :: Int -> a -> Doc- pprPrec _ = ppr+ pprPrec :: Int -> a -> Doc+ pprPrec p = pprModePrec pprDefaultMode p + pprModePrec :: PrettyMode a -> Int -> a -> Doc+ pprModePrec _ _ x = ppr x + +instance Pretty () where+ ppr = text . show+ instance Pretty Bool where- ppr = text . show+ ppr = text . show instance Pretty Int where- ppr = text . show+ ppr = text . show +instance Pretty Integer where+ ppr = text . show+ instance Pretty Char where- ppr = text . show+ ppr = text . show instance Pretty a => Pretty [a] where ppr xs = encloseSep lbracket rbracket comma @@ -57,6 +72,15 @@ instance (Pretty a, Pretty b) => Pretty (a, b) where ppr (a, b) = parens $ ppr a <> comma <> ppr b+++padL :: Int -> Doc -> Doc+padL n d+ = let len = length $ renderPlain d+ pad = n - len+ in if pad > 0+ then d <> text (replicate pad ' ')+ else d -- Rendering ------------------------------------------------------------------
+ DDC/Control/Monad/Check.hs view
@@ -0,0 +1,73 @@++-- | A simple exception monad.+module DDC.Control.Monad.Check+ ( CheckM (..)+ , throw+ , runCheck+ , evalCheck+ , get+ , put)+where+import Control.Monad+++-- | Checker monad maintains some state and manages errors during type checking.+data CheckM s err a+ = CheckM (s -> (s, Either err a))+++instance Functor (CheckM s err) where+ fmap = liftM+++instance Applicative (CheckM s err) where+ (<*>) = ap+ pure = return+++instance Monad (CheckM s err) where+ return !x + = CheckM (\s -> (s, Right x))+ {-# INLINE return #-}++ (>>=) !(CheckM f) !g + = CheckM $ \s + -> case f s of+ (s', Left err) -> (s', Left err)+ (s', Right x) -> s `seq` x `seq` runCheck s' (g x)+ {-# INLINE (>>=) #-}+++-- | Run a checker computation,+-- returning the result and new state.+runCheck :: s -> CheckM s err a -> (s, Either err a)+runCheck s (CheckM f) = f s+{-# INLINE runCheck #-}+++-- | Run a checker computation, +-- ignoreing the final state.+evalCheck :: s -> CheckM s err a -> Either err a+evalCheck s m = snd $ runCheck s m+{-# INLINE evalCheck #-}+++-- | Throw a type error in the monad.+throw :: err -> CheckM s err a+throw !e = CheckM $ \s -> (s, Left e)+{-# INLINE throw #-}+++-- | Get the state from the monad.+get :: CheckM s err s+get = CheckM $ \s -> (s, Right s)+{-# INLINE get #-}+++-- | Put a new state into the monad.+put :: s -> CheckM s err ()+put s + = CheckM $ \_ -> (s, Right ())+{-# INLINE put #-}++
+ DDC/Data/Canned.hs view
@@ -0,0 +1,13 @@++module DDC.Data.Canned+ (Canned(..))+where++-- | This function has a show instance that prints \"CANNED\" for any contained+-- type. We use it to wrap functional fields in data types that we still want+-- to derive Show instances for.+data Canned a+ = Canned a++instance Show (Canned a) where+ show _ = "CANNED"
+ DDC/Data/ListUtils.hs view
@@ -0,0 +1,75 @@++-- | Replacements for unhelpful Haskell list functions.+-- If the standard versions are passed an empty list then we don't+-- get a proper source location.+module DDC.Data.ListUtils+ ( takeHead+ , takeTail+ , takeInit+ , takeMaximum+ , index+ , findDuplicates+ , stripSuffix)+where+import Data.List+import qualified Data.Set as Set+++-- | Take the head of a list, or `Nothing` if it's empty.+takeHead :: [a] -> Maybe a+takeHead xs+ = case xs of+ [] -> Nothing+ _ -> Just (head xs)+++-- | Take the tail of a list, or `Nothing` if it's empty.+takeTail :: [a] -> Maybe [a]+takeTail xs+ = case xs of+ [] -> Nothing+ _ -> Just (tail xs)+++-- | Take the init of a list, or `Nothing` if it's empty.+takeInit :: [a] -> Maybe [a]+takeInit xs+ = case xs of+ [] -> Nothing+ _ -> Just (init xs)+++-- | Take the maximum of a list, or `Nothing` if it's empty.+takeMaximum :: Ord a => [a] -> Maybe a+takeMaximum xs+ = case xs of+ [] -> Nothing+ _ -> Just (maximum xs)+++-- | Retrieve the element at the given index,+-- or `Nothing if it's not there.+index :: [a] -> Int -> Maybe a+index [] _ = Nothing+index (x : _) 0 = Just x+index (_ : xs) i = index xs (i - 1)++++-- | Find the duplicate values in a list.+findDuplicates :: Ord n => [n] -> [n]+findDuplicates xx+ = go (Set.fromList xx) xx+ where go _ [] = []+ go ss (x : xs)+ | Set.member x ss = go (Set.delete x ss) xs+ | otherwise = x : go ss xs+++-- | Drops the given suffix from a list.+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix suff xx+ = case stripPrefix (reverse suff) (reverse xx) of+ Nothing -> Nothing+ Just xs -> Just $ reverse xs+
+ DDC/Data/SourcePos.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TypeFamilies #-}+module DDC.Data.SourcePos+ (SourcePos (..))+where+import DDC.Base.Pretty+import Control.DeepSeq++-- | A position in a 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+ { sourcePosSource :: String+ , sourcePosLine :: Int+ , sourcePosColumn :: Int }+ deriving (Eq, Show)+++instance NFData SourcePos where+ rnf (SourcePos str l c)+ = rnf str `seq` rnf l `seq` rnf c+++instance Pretty SourcePos where+ -- Suppress printing of line and column number when they are both zero.+ -- File line numbers officially start from 1, so having 0 0 probably+ -- means this isn't real information.+ ppr (SourcePos source 0 0)+ = text $ source++ ppr (SourcePos source l c) + = text $ source ++ ":" ++ show l ++ ":" ++ show c+
+ DDC/Data/Token.hs view
@@ -0,0 +1,36 @@++module DDC.Data.Token+ ( Token(..)+ , takeParsecSourcePos+ , tokenLine+ , tokenColumn)+where+import DDC.Data.SourcePos+import qualified Text.Parsec.Pos as P+++-- | 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 source l c+ -> P.newPos source l c+++-- | Take the line number of a token.+tokenLine :: Token t -> Int+tokenLine (Token _ (SourcePos _ l _)) = l+++-- | Take the column number of a token.+tokenColumn :: Token t -> Int+tokenColumn (Token _ (SourcePos _ _ c)) = c+
+ DDC/Version.hs view
@@ -0,0 +1,8 @@++module DDC.Version where++splash :: String+splash = "The Disciplined Disciple Compiler, version " ++ version++version :: String+version = "0.4.2"
LICENSE view
@@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- The Disciplined Disciple Compiler License (MIT style) -Copyrite (K) 2007-2012 The Disciplined Disciple Compiler Strike Force+Copyrite (K) 2007-2014 The Disciplined Disciple Compiler Strike Force All rights reversed. Permission is hereby granted, free of charge, to any person obtaining a copy@@ -13,18 +13,4 @@ The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.----------------------------------------------------------------------------------Under Australian law copyright is free and automatic.-By contributing to DDC authors grant all rights they have regarding their-contributions to the other members of the Disciplined Disciple Compiler Strike-Force, past, present and future, as well as placing their contributions under-the above license.--Use "darcs show authors" to get a list of Strike Force members.- ---------------------------------------------------------------------------------Redistributions of libraries in ./external are governed by their own licenses:-- - TinyPTC GNU Lesser General Public License-
ddc-base.cabal view
@@ -1,5 +1,5 @@ Name: ddc-base-Version: 0.2.1.2+Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -9,28 +9,42 @@ Stability: experimental Category: Compilers/Interpreters Homepage: http://disciple.ouroborus.net-Bug-reports: disciple@ouroborus.net-Synopsis: Disciple Core language common utilities. +Synopsis: Disciplined Disciple Compiler common utilities. Description: This package re-exports the main external dependencies of - the Disciplined Disciple Compiler project.+ the Disciplined Disciple Compiler project, and provides some+ common utilities. Library Build-Depends: - base == 4.6.*,- transformers == 0.3.*,- containers == 0.5.*,- wl-pprint == 1.1.*,- parsec == 3.1.*-+ base >= 4.8 && < 4.9,+ deepseq >= 1.4 && < 1.5,+ transformers >= 0.4 && < 0.5,+ containers >= 0.5.6 && < 0.6,+ wl-pprint >= 1.1 && < 1.3,+ parsec >= 3.1 && < 3.2+ Exposed-modules:- DDC.Base.Lexer+ DDC.Base.Env+ DDC.Base.Name+ DDC.Base.Panic DDC.Base.Parser DDC.Base.Pretty++ DDC.Control.Monad.Check++ DDC.Data.Canned+ DDC.Data.ListUtils+ DDC.Data.SourcePos+ DDC.Data.Token++ DDC.Version GHC-options: -Wall -fno-warn-orphans+ -fno-warn-type-defaults+ -fno-warn-missing-methods Extensions: ParallelListComp@@ -38,3 +52,4 @@ RankNTypes FlexibleContexts KindSignatures+ BangPatterns