ddc-base 0.3.2.1 → 0.4.2.1
raw patch · 11 files changed
Files
- DDC/Base/Env.hs +174/−0
- DDC/Base/Name.hs +22/−0
- DDC/Base/Panic.hs +23/−0
- DDC/Base/Parser.hs +16/−3
- DDC/Base/Pretty.hs +28/−9
- DDC/Control/Monad/Check.hs +53/−14
- DDC/Data/ListUtils.hs +34/−1
- DDC/Data/SourcePos.hs +3/−3
- DDC/Version.hs +8/−0
- LICENSE +1/−15
- ddc-base.cabal +16/−9
+ 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/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,10 +1,11 @@+{-# LANGUAGE TypeFamilies #-} -- | Parser utilities. module DDC.Base.Parser ( module Text.Parsec , Parser , ParserState (..)- , D.SourcePos+ , D.SourcePos (..) , runTokenParser , pTokMaybe, pTokMaybeSP , pTokAs, pTokAsSP@@ -33,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.@@ -43,11 +44,19 @@ -> 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 -------------------------------------------------------------------------------@@ -107,12 +116,16 @@ ------------------------------------------------------------------------------- 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,28 +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+ 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+ 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 @@ -62,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
@@ -3,32 +3,71 @@ module DDC.Control.Monad.Check ( CheckM (..) , throw- , result)+ , runCheck+ , evalCheck+ , get+ , put) where+import Control.Monad -data CheckM err a- = CheckM (Either err a)+-- | Checker monad maintains some state and manages errors during type checking.+data CheckM s err a+ = CheckM (s -> (s, Either err a)) -instance Monad (CheckM err) where+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 (Right x)+ = CheckM (\s -> (s, Right x)) {-# INLINE return #-} - (>>=) !m !f - = case m of- CheckM (Left err) -> CheckM (Left err)- CheckM (Right x) -> x `seq` f x+ (>>=) !(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 err a-throw !e = CheckM $ Left e+throw :: err -> CheckM s err a+throw !e = CheckM $ \s -> (s, Left e)+{-# INLINE throw #-} --- | Take the result from a check monad.-result :: CheckM err a -> Either err a-result (CheckM r) = r+-- | 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/ListUtils.hs view
@@ -6,8 +6,13 @@ ( takeHead , takeTail , takeInit- , index)+ , 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.@@ -34,9 +39,37 @@ _ -> 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
@@ -1,4 +1,4 @@-+{-# LANGUAGE TypeFamilies #-} module DDC.Data.SourcePos (SourcePos (..)) where@@ -27,8 +27,8 @@ -- File line numbers officially start from 1, so having 0 0 probably -- means this isn't real information. ppr (SourcePos source 0 0)- = ppr $ source+ = text $ source ppr (SourcePos source l c) - = ppr $ source ++ ":" ++ show l ++ ":" ++ show c+ = text $ source ++ ":" ++ show l ++ ":" ++ show 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-2013 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.3.2.1+Version: 0.4.2.1 License: MIT License-file: LICENSE Author: The Disciplined Disciple Compiler Strike Force@@ -17,27 +17,34 @@ Library Build-Depends: - base == 4.6.*,- transformers == 0.3.*,- containers == 0.5.*,- wl-pprint == 1.1.*,- parsec == 3.1.*,- deepseq == 1.3.*-+ 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.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.Data.ListUtils++ DDC.Version GHC-options: -Wall -fno-warn-orphans+ -fno-warn-type-defaults+ -fno-warn-missing-methods Extensions: ParallelListComp