diff --git a/Control/Monad/Environment.hs b/Control/Monad/Environment.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Environment.hs @@ -0,0 +1,311 @@ +{-| We provide an implementation of environments, as well as a monad + for performing computations in mutable environments. See 'Env' for + the definition of environments that we are using here. See + 'EnvironmentT' for details on what is available withing a mutable + environment computation. +-} +module Control.Monad.Environment ( + EnvironmentT + , Env + , MEnv + , Bindings + , EnvironmentIO + , EnvironmentST + + --, runEnvironmentT + , evalEnvironmentT + --, execEnvironmentT + + , extractLocal + , extractParent + , copyEnv + , copyLocalEnv + + , find + , bind + , findIn + , bindIn + + , getEnv + , getFindEnv + , getBindEnv + , withEnv + , emptyEnv + , freshEnv + , localEnv + , letInEnv + ) where + +import qualified Data.Ref as Ref + +import Data.Monoid +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State + +import Control.Monad.ST (ST) +import Control.Monad.Identity (Identity) + +--TODO implement with something faster than an AList + +------ Types ------ +{-| Environments, also called contexts, are a set of bindings along with an optional parent + environment. + + When an environment is searched for a key, it first looks in its own bindings map, then looks + in its parent's. When a binding is added to an environment, the environments own bindings are + updated; its ancestors remain unchanged. +-} +data Env k v = Env (Bindings k v) (Maybe (Env k v)) +--FIXME I actually can merge Maps, so I may as well do it that way instead of using parents + +{-| Where 'Env' represents immutable (mathematical) environments, 'MEnv' represent mutable + environments. Mutable environments can be useful for accumulating recursive bindings, + or for interpreting languages with mutable binding environments. + + The implementation of mutable cells (allocation, reading, writing) is abstracted by @m@. See + @Data.Ref@ for more information. +-} +data MEnv m k v = MEnv (Ref.T m (Bindings k v)) (Maybe (MEnv m k v)) +{-| Synonym for some key-value mapping. -} +type Bindings k v = [(k, v)] + +{-| Perform computations involving the manipulation of @MEnv m k v@ terms. + + Within the monad, we track not only the active (current) environment, but we also + provide a default environment. The default environment is intended as a \"top-level\" + environment that is available when using 'freshEnv'. For environments that do not reference + the default environment, use 'emptyEnv'. +-} +newtype EnvironmentT k v m a = E { unEnvT :: StateT (MEnv m k v, MEnv m k v) (ReaderT (Bindings k v) m) a } + +{-| Run the Environment monad with 'IORef's. -} +type EnvironmentIO k v = EnvironmentT k v IO +{-| Run the Environment monad with 'STRef's. -} +type EnvironmentST s k v = EnvironmentT k v (ST s) + +type DefaultEnv k v = Bindings k v +type ActiveEnv k v = Bindings k v +newtype EnvState k v = EnvState { unState :: (DefaultEnv k v, ActiveEnv k v) } + + +------ Top-Level ------ + +--TODO we can acheive limited restarts by: run part one, flatten & return the current env, do whatever, then initialize with it again + +--runEnvironment :: [(k, v)] -> EnvironmentT k v m a -> m (a, EnvState k v) +--runEnvironment env action = error "STUB" + +--evalEnvironment :: (Ref.C m) => Bindings k v -> EnvironmentT k v m a -> m a +--evalEnvironment bindings = runIdentity . evalEnvironmentT bindings + +{-| Provided a bindings for a default environment, run an environment computation. -} +evalEnvironmentT :: (Ref.C m) => Bindings k v -> EnvironmentT k v m a -> m a +evalEnvironmentT xs (E action) = do + env0 <- flip MEnv Nothing `liftM` Ref.new xs + runReaderT (evalStateT action (env0, env0)) xs + +--execEnvironment :: [(k, v)] -> EnvironmentT k v m a -> m (EnvState k v) +--execEnvironment env action = liftM snd (runEnvironment env action) + +--resumeEnvironment :: (Monad m) => EnvState k v -> EnvironmentT k v m () +--resumeEnvironment = error "STUB" + + +------ Environment Manipulators ------ +{-| Retrieve an @MEnv@ in every way equal to the one passed, except that the result has no parent. + + The cell in the new environment continues to reference the old, so changes in the state of one + are mirrored in the other. +-} +extractLocal :: MEnv m k v -> MEnv m k v +extractLocal (MEnv cell _) = MEnv cell Nothing + +{-| Retrieve the parent of the passed @MEnv@. -} +extractParent :: MEnv m k v -> Maybe (MEnv m k v) +extractParent (MEnv _ parent) = parent + +{-| Make a deep copy of the passed environment. + + That is, both the @MEnv@'s own bindings cell is copied, the parent (if any) is copied, and a new + environment is constructed of the two, which shares no state with the original with respect to + @find@ and @bind@. Bound values are not copied, however, so state may still be shared insofar + as the bound values have state. +-} +copyEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (MEnv m k v) +copyEnv (MEnv cell parent) = do + xs' <- liftHeap $ Ref.read cell + parent' <- case parent of + Nothing -> return Nothing + Just parent -> Just <$> copyEnv parent + newEnv xs' parent' + +{-| Make a shallow copy of the passed environment + + That is, only the @MEnv@'s own bindings cell is copied; the parent (if any) is not copied. + A new environment is constructed of the two, which shares only enough state with the original + so that writes to the new do not affect the original, and only writes to the parents of the + original are available (modulo shadowing) in the new. Bound values are not copied, however, + so state may also be shared insofar as the bound values have state. +-} +copyLocalEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (MEnv m k v) +copyLocalEnv (MEnv cell parent) = do + xs' <- liftHeap $ Ref.read cell + newEnv xs' parent + +{-| Create an immutable environment from a snapshot of the passed mutable environment. -} +closeEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m (Env k v) +closeEnv (MEnv cell parent) = do + xs <- liftHeap $ Ref.read cell + parent' <- case parent of + Just p -> Just <$> closeEnv p + Nothing -> return Nothing + return $ Env xs parent' + + +------ Binding and Lookup ------ +{-| Lookup the value associated with the passed key in the current environment. + See 'Env', 'getFindEnv'. +-} +find :: (Ref.C m, Eq k) => k -> EnvironmentT k v m (Maybe v) +find k = getFindEnv >>= \env -> findIn env k + +{-| Bind the key to the value in the current environment. + See 'Env', 'getFindEnv'. +-} +bind :: (Ref.C m) => k -> v -> EnvironmentT k v m () +bind k v = getBindEnv >>= \env -> bindIn env k v +-- This is why I want something more like Murex: bind ≡ (bindIn _ k v) =<< getFindEnv + +{-| Lookup the value associated with the passed key in the passed 'MEnv'. + See 'Env' for more detail on the search semantics. + + We have @'findIn' e k v === 'withEnv' e ('find' k v)@, but the implementation + of 'findIn' does less bookkeeping internally. +-} +findIn :: (Ref.C m, Eq k) => MEnv m k v -> k -> EnvironmentT k v m (Maybe v) +findIn env@(MEnv cell Nothing) k = findInLocally env k +findIn env@(MEnv cell (Just parent)) k = do + result <- findInLocally env k + case result of + Just _ -> return result + Nothing -> findIn parent k + +{-| Bind a key to a value in the passed 'MEnv'. See 'Env' for more detail on the search semantics. + + We have @'bindIn' e k v === 'withEnv' e ('bind' k v)@, but the implementation of + 'findIn' does less bookkeeping internally. +-} +bindIn :: (Ref.C m) => MEnv m k v -> k -> v -> EnvironmentT k v m () +bindIn (MEnv cell _) k v = liftHeap $ Ref.modify cell ((k, v):) + +{-| Equivalent to @'findIn' . 'extractLocal'@, but it's more direct + to define 'findIn' in terms of this. -} +findInLocally :: (Ref.C m, Eq k) => MEnv m k v -> k -> EnvironmentT k v m (Maybe v) +findInLocally (MEnv cell _) k = lookup k <$> liftHeap (Ref.read cell) + + +------ Current Environment Manipulation ------ +{-| Synonym for 'getFindEnv'. -} +getEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v) +getEnv = getFindEnv + +{-| Obtain a handle to the environment in which searches begin. -} +getFindEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v) +getFindEnv = fst <$> liftActiveEnv get + +{-| Obtain a handle to the environment in which searches begin. -} +getBindEnv :: (Ref.C m) => EnvironmentT k v m (MEnv m k v) +getBindEnv = snd <$> liftActiveEnv get + +{-| Perform an action in the given environment. -} +withEnv :: (Ref.C m) => MEnv m k v -> EnvironmentT k v m a -> EnvironmentT k v m a +withEnv env' action = do + env <- liftActiveEnv get + liftActiveEnv (put (env', env')) >> action << liftActiveEnv (put env) + +--TODO withFindEnv, withBindEnv + +{-| Perform an action in a new, empty, parentless environment. -} +emptyEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a +emptyEnv action = do + env' <- newEnv [] Nothing + withEnv env' action + +{-| Perform an action in a new, default, parentless environment. -} +freshEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a +freshEnv action = do + bindings <- liftDefaultEnv ask + env' <- newEnv bindings Nothing + withEnv env' action + +{-| Perform an action in a new, initially empty environment, child to the current. -} +localEnv :: (Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m a +localEnv action = do + env' <- newEnv [] =<< liftM Just getFindEnv + withEnv env' action + +{-| Perform the first action in a 'localEnv', then perform the second with the + binding environment the same as the original finding environment. +-} +letInEnv ::(Ref.C m) => EnvironmentT k v m a -> EnvironmentT k v m b -> EnvironmentT k v m b +letInEnv letAction inAction = do + env0 <- liftActiveEnv get + env <- getFindEnv + env' <- newEnv [] (Just env) + liftActiveEnv $ put (env', env') + letAction + liftActiveEnv $ put (env', env) + res <- inAction + liftActiveEnv $ put env0 + return res + + +------ Helpers ------ +infixl 1 << +a << b = do { r <- a; b; return r } + +newEnv :: (Ref.C m) => Bindings k v -> Maybe (MEnv m k v) -> EnvironmentT k v m (MEnv m k v) +newEnv xs parent = do + env <- liftHeap $ Ref.new xs + return $ MEnv env parent + +liftActiveEnv :: (Ref.C m) => StateT (MEnv m k v, MEnv m k v) (ReaderT (Bindings k v) m) a -> EnvironmentT k v m a +liftActiveEnv = E +liftDefaultEnv :: (Ref.C m) => ReaderT (Bindings k v) m a -> EnvironmentT k v m a +liftDefaultEnv = E . lift +liftHeap :: (Ref.C m) => m a -> EnvironmentT k v m a +liftHeap = E . lift . lift + + +------ Instances ------ +instance Monoid (Env k v) where + mempty = Env [] Nothing + mappend env (Env xs Nothing) | null xs = env + | otherwise = Env xs (Just env) + mappend env (Env xs (Just parent)) | null xs = env `mappend` parent + | otherwise = Env xs (Just $ env `mappend` parent) +--TODO monoid for MEnv + + +instance (Ref.C m) => Functor (EnvironmentT k v m) where + fmap = liftM + +instance (Ref.C m) => Applicative (EnvironmentT k v m) where + pure = return + (<*>) = ap + +instance (Ref.C m) => Monad (EnvironmentT k v m) where + return = E . return + x >>= k = E (unEnvT . k =<< unEnvT x) + +instance MonadTrans (EnvironmentT k v) where + lift = E . lift . lift + +instance (MonadIO m, Ref.C m) => MonadIO (EnvironmentT k v m) where + liftIO = lift . liftIO + +---- TODO any stdlib monads + diff --git a/Control/Monad/Errors.hs b/Control/Monad/Errors.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Errors.hs @@ -0,0 +1,137 @@ +{-| In many error-checking algorithms, it is desireable to report several + errors rather than simply terminate on detecting the first error. + + Where 'Either' and 'Error' terminates on the first error, 'Errors' can + recover at specified points and continue error-checking. Even after a + recovery, the prior errors are logged. If any errors occured during + error-checking, this si an error in the whole computation. +-} +module Control.Monad.Errors ( + -- * Errors Monad + Errors + , runErrors + -- * Error Reporting Functions + , err + , err1 + , choice + , recover + , recover_ + , mapRecover + , unrecover + -- ** Hoisting Functions + , hoistMaybe + , hoistEither + , hoistEither1 + -- * Errors Transformer + , ErrorsT + , runErrorsT + ) where + +import Data.Monoid +import Data.Either +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Control.Monad.Writer +import Control.Monad.Trans +import Control.Monad.Trans.Either hiding (hoistEither) + + +{-| Shortcut for 'ErrorsT' over the 'Identity' monad. -} +type Errors e = ErrorsT e Identity +{-| Computations that can collect multiple errors. -} +newtype ErrorsT e m a = ErrorsT { unErrors :: m (Maybe e -> (Maybe a, Maybe e)) } + +{-| Perform an error-reporting computation. -} +runErrors :: (Monoid e) => Errors e a -> Either e a +runErrors = runIdentity . runErrorsT + +{-| Perform the error reporting part of a computation. -} +runErrorsT :: (Monad m, Monoid e) => ErrorsT e m a -> m (Either e a) +runErrorsT action = do + innerAction <- unErrors action + let res = innerAction Nothing + return $ case res of + (Just val, Nothing) -> Right val + (_, Just errs) -> Left errs + (Nothing, Nothing) -> error "Control.Monad.Errors: internal error" + + +{-| Report an error. -} +err :: (Monad m, Monoid e) => e -> ErrorsT e m a +err msg = ErrorsT . return $ \e -> (Nothing, e <> Just msg) + +{-| Report one error accumulating in a list. -} +err1 :: (Monad m) => e -> ErrorsT [e] m a +err1 = err . (:[]) + +{-| Try several alternatives (in order), but if none succeed, raise the passed error. -} +choice :: (Monad m, Monoid e) => e -> [ErrorsT e m a] -> ErrorsT e m a +choice e0 [] = err e0 +choice e0 (a:as) = do + res <- lift $ runErrorsT a + case res of + Left e0 -> choice e0 as + Right val -> return val + +{-| If the action returns an error, relpace the result with a default. + The error is still logged and reported at the end of the computation. -} +recover :: (Monad m, Monoid e) => a -> ErrorsT e m a -> ErrorsT e m a +recover replacement action = ErrorsT $ do + res <- runErrorsT action + return $ case res of + Left err -> \e -> (Just replacement, e <> Just err) + Right val -> \e -> (Just val, e) + +{-| As 'recover', but any successful result value does not matter. -} +recover_ :: (Monad m, Monoid e) => ErrorsT e m a -> ErrorsT e m () +recover_ action = recover () (const () <$> action) + +{-| Perform many error checks, recovering between each. The value at each index of the output + list corresponds to the index of the input computation list. Error values are 'Nothing' + in the output, successful values are wrapped in 'Just'. -} +mapRecover :: (Monad m, Monoid e) => [ErrorsT e m a] -> ErrorsT e m [Maybe a] +mapRecover actions = mapM (recover Nothing . (Just <$>)) actions + +{-| If any errors have been detected, cuase them to be loud again. -} +unrecover :: (Monad m, Monoid e) => ErrorsT e m () +unrecover = ErrorsT . return $ \e -> case e of + Nothing -> (Just (), e) + Just _ -> (Nothing, e) + + +{-| Turn a 'Maybe' computation into an 'ErrorsT' computation. -} +hoistMaybe :: (Monad m, Monoid e) => e -> Maybe a -> ErrorsT e m a +hoistMaybe e = maybe (err e) return + +{-| Turn an 'Either' computation into an 'ErrorsT' computation. -} +hoistEither :: (Monad m, Monoid e) => Either e a -> ErrorsT e m a +hoistEither = either err return + +{-| Turn an 'Either' computation into an 'ErrorsT' computation when accumulating a list. -} +hoistEither1 :: (Monad m) => Either e a -> ErrorsT [e] m a +hoistEither1 = either err1 return + + +instance (Monad m, Monoid e) => Functor (ErrorsT e m) where + fmap = liftM + +instance (Monad m, Monoid e) => Applicative (ErrorsT e m) where + pure = return + (<*>) = ap + +instance (Monad m, Monoid e) => Monad (ErrorsT e m) where + return x = ErrorsT . return $ \e -> (Just x, e) + x >>= k = ErrorsT $ do + eRes <- runErrorsT x + case eRes of + Left err -> return $ \e -> (Nothing, e <> Just err) + Right val -> unErrors $ k val + +instance (Monoid e) => MonadTrans (ErrorsT e) where + lift x = ErrorsT $ do + x' <- x + return $ \e -> (Just x', e) + +instance (MonadIO m, Monoid e) => MonadIO (ErrorsT e m) where + liftIO = lift . liftIO diff --git a/Control/Monad/Gensym.hs b/Control/Monad/Gensym.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Gensym.hs @@ -0,0 +1,97 @@ +{-| Computations involving the generation of fresh symbols. + + The notion of what is a symbol is abstracted by the 'Gensym' class. + Then, we provide the 'SymbolGen' monad and 'SymbolGenT' monad transformer, + in which symbols may be generated. + + Symbols are generated deterministically, but also without reference to any + other sources of symbols, such as the programmer's algorithms, user input or + other SymbolGen monads. Therefore, make sure the symbols you generate are + trivially distinct from all other sources of symbols. +-} +module Control.Monad.Gensym ( + -- * Generate Symbols + Gensym(..) + , gensym + -- * Symbol Generator Monad + , SymbolGen + , runSymbolGen + -- * Symbol Generator Monad Transformer + , SymbolGenT + , runSymbolGenT + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State.Strict +import Control.Monad.Trans +import Control.Monad.Trans.Either +import Data.Ref (new, newLifted) +import qualified Data.Ref as Ref + + +------ Concepts ------ +{-| Class for types that can provide an infinite supply of distinct values. -} +class Gensym s where + {-| The initial symbol generated. -} + genzero :: s + {-| Given the last symbol generated, generate the next. + Must be distinct from all other symbols generated. + -} + nextsym :: s -> s + + +{-| Monad transformer adding the capability of generating fresh symbols. -} +newtype SymbolGenT s m a = SymbolGenT { unSymbolGenT :: StateT s m a } + +{-| Perform a computation involving generating fresh symbols. -} +runSymbolGenT :: (Gensym s, Monad m) => SymbolGenT s m a -> m a +runSymbolGenT = flip evalStateT genzero . unSymbolGenT + +{-| Synonym for SymbolGenT over Identity. -} +type SymbolGen s = SymbolGenT s Identity + +{-| Synonym for @'runIdentity' . 'runSymbolGenT'@. -} +runSymbolGen :: (Gensym s) => SymbolGen s a -> a +runSymbolGen = runIdentity . runSymbolGenT + +{-| Generate a fresh symbol. Of course, this monad does not know + what other sources of symbols there are, so make sure your 'Gensym' + instance generates symbols distinct from all others. -} +gensym :: (Gensym s, Monad m) => SymbolGenT s m s +gensym = SymbolGenT $ do + sym <- get + modify nextsym + return sym + + +------- Basic Instances ------ +instance Gensym Integer where + genzero = 0 + nextsym = (+1) + +instance (Monad m) => Functor (SymbolGenT s m) where + fmap = liftM + +instance (Monad m) => Applicative (SymbolGenT s m) where + pure = return + (<*>) = ap + +instance (Monad m) => Monad (SymbolGenT s m) where + return = SymbolGenT . return + x >>= k = SymbolGenT $ unSymbolGenT x >>= unSymbolGenT . k + +instance MonadTrans (SymbolGenT s) where + lift = SymbolGenT . lift + +instance (MonadIO m) => MonadIO (SymbolGenT s m) where + liftIO = lift . liftIO + +instance (Ref.C m) => Ref.C (SymbolGenT s m) where new = newLifted + +------ Transformer Instances ------ +instance (Ref.C m) => Ref.C (EitherT e m) where new = newLifted + +--TODO instances for other stdlib & spinelib monads + diff --git a/Control/Monad/Stack.hs b/Control/Monad/Stack.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Stack.hs @@ -0,0 +1,74 @@ +module Control.Monad.Stack ( + Stack + , runStack + , StackT + , runStackT + , peek + , pop + , push + , peeks + , testTop + ) where + +import Data.Maybe +import Control.Applicative +import Control.Monad +import Control.Monad.Identity +import Control.Monad.State.Strict +import Control.Monad.Trans + + +type Stack s = StackT s Identity + +newtype StackT s m a = StackT { unStack :: StateT [s] m a } + +runStack :: Stack s a -> a +runStack = runIdentity . runStackT + +runStackT :: (Monad m) => StackT s m a -> m a +runStackT = flip evalStateT [] . unStack + + +peek :: (Monad m) => StackT s m (Maybe s) +peek = StackT $ do + stack <- get + return $ case stack of + [] -> Nothing + (x:_) -> Just x +pop :: (Monad m) => StackT s m (Maybe s) +pop = StackT $ do + stack <- get + case stack of + [] -> return Nothing + (x:xs) -> put xs >> return (Just x) +push :: (Monad m) => s -> StackT s m () +push x = StackT $ modify (x:) >> return () + + +peeks :: (Monad m) => (s -> a) -> StackT s m (Maybe a) +peeks f = (fmap . fmap) f peek + +testTop :: (Monad m) => (s -> Bool) -> StackT s m Bool +testTop = (fromMaybe False <$>) . peeks + + + +instance (Monad m) => Functor (StackT s m) where + fmap = liftM +instance (Monad m) => Applicative (StackT s m) where + pure = return + (<*>) = ap + +instance (Monad m) => Monad (StackT s m) where + return = StackT . return + x >>= k = StackT $ unStack x >>= unStack . k + +instance MonadTrans (StackT s) where + lift = StackT . lift + +instance (MonadIO m) => MonadIO (StackT s m) where + liftIO = lift . liftIO + + + + diff --git a/Data/FiniteType.hs b/Data/FiniteType.hs new file mode 100644 --- /dev/null +++ b/Data/FiniteType.hs @@ -0,0 +1,106 @@ +{-| Finite types are well-known in theory. For those who aren't theorists, there are two kinds of + finite type: finite products and finite sums (also called finite coproducts). + + Finite products are a generalization of tuples and records. Where tuples are indexed by + integer and records ar eindexed by name, finite products can use any index set. Finite sums + are a generalization of discriminated unions (also called variants) so that, again, they are + indexed by any set. + + Finite products and sums are useful generally for organizing data, but can be particularly + useful where functinos are curried. A finite product using @Either Int String@ (or similar) + as an index set, we can easily simulate a mix of positional and keyword arguments to such + functions. With finite sums, we can specify the type of a function which can take one of + multiple valid sets of arguments. +-} +module Data.FiniteType ( + Product + , mkProduct + , getProd + , setProd + , hasProd + , Sum + , mkSum + , getSum + , setSum + , hasSum + , SumTemplate + , mkSumTemplate + ) where + +import Data.List +import Data.Maybe +import Control.Applicative + + +------ Types ------ +{-| Types where every field in the index set is filled with a value. -} +data Product i a = Product [(i, a)] + +{-| Types where exactly one feild in the index set is filled with a value. -} +data Sum i a = Sum i a (SumTemplate i) + +{-| Template from which a finite sum may be created. + + Generally, you would define a @'Product' MyIxSet MyType@ in your language's statics, + then transform this into a @'SumTemplate' MyIxSet@ template with 'mkSumTemplate', and use + that template with 'mkSum' to create actual @'Sum' MyIxSet MyValue@ values in your + interpreter. +-} +data SumTemplate i = SumTemplate [i] + + +------ Creation ------ +{-| Form a 'Product' with all fields filled from an association list. + Error if the keys are not distinct. +-} +mkProduct :: (Eq i) => [(i, a)] -> Product i a +mkProduct xs = let ixSet = fst <$> xs + in if ixSet == nub ixSet + then Product xs + else error "Finite Product: index set not distinct" + +{-| Form a 'Sum' filling the passed index with the passed value. -} +mkSum :: (Eq i) => SumTemplate i -> i -> a -> Sum i a +mkSum t i v = Sum i v t + + + +{-| Create a 'SumTemplate' with index set identical to the input. -} +mkSumTemplate :: Product i a -> SumTemplate i +mkSumTemplate (Product xs) = SumTemplate (fst <$> xs) +-- don't have to check for distinct, because that's guaranteed by Product invariant + + +------ Access ------ +{-| Look up a field of a finite product. Error if the field does not exist. -} +getProd :: (Eq i) => Product i a -> i -> a +getProd (Product xs) i = fromJust $ i `lookup` xs + +{-| Extract the value of the unique filled field in a finite sum. -} +getSum :: Sum i a -> a +getSum (Sum i a t) = a + +{-| Check for existence of a field in a finite product. -} +hasProd :: (Eq i) => Product i a -> i -> Bool +hasProd (Product xs) i = i `elem` (fst <$> xs) + +{-| Determine which field is filled in a finite sum. -} +hasSum :: Sum i a -> i +hasSum (Sum i x t) = i + + +------ Modification ------ +{-| Modify a field of a finite product. Error if the field does not exist. -} +setProd :: (Eq i) => Product i a -> i -> a -> Product i a +setProd (Product xs) i v = Product (go xs []) + where + go [] xs' = error "Finite Product: field not in index set" + go (x:xs) xs' | i == fst x = reverse xs' ++ (i, v):xs + | otherwise = go xs (x:xs') + +{-| Modify a field of a finite sum. Error if the field does not exist. -} +setSum :: (Eq i) => Sum i a -> i -> a -> Sum i a +setSum (Sum _ _ t@(SumTemplate is)) i v = if i `elem` is + then Sum i v t + else error "Finite Sum: field not in index set" + diff --git a/Data/Hexpr.hs b/Data/Hexpr.hs new file mode 100644 --- /dev/null +++ b/Data/Hexpr.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +--TODO some sort of Homoiconic class, which can is required for Functor so that fmap can delve into code objects +-- well, required for functor might be too strong, instead provide a some sort of hmap that can delve, but requires Functor and Homoiconic +{-| Hexprs are a data structure for representing and storing first-class code objects in a + strongly-, statically-typed language. + + In an untyped language, first-class code may be represented by simple lists, which may then + hold both atomic values as well as other lists. As code objects will need to be manipulated + regularly, untyped lists (or @[∀a.a]@, if you prefer) are insufficient in a statically typed + language. We therefore introduce 'Hexpr's, which is the type of the extended context-free + grammar family @S ::= @/atom/@ | (SS@/+/@)@. + + By contrast, the grammar of s-exprs is @S ::= @/atom/@ | (SS@/*/@)@, which also has an + associated type. However, s-exprs are less suitable for mathematical reasoning. Note that + s-exprs distinguish between @a@ and @(a)@, which is entirely contrary to mathematical notation, + wherein superfluous parenthesis may be dropped, and often should be for social reasons. While + I'm at it, I may as well say the grammar of roses is @S ::= @/atom/@ | @/atom/@(S@/*/@)@. + + Because languages with first-class code benefit greatly from quasiquotation, we also introduce + the 'Quasihexpr', which is isomorphic to 'Hexpr'. We give algorithms for encoding quasihexprs + into hexprs, see 'UnQuasihexpr' and 'SimplifyHexpr' for more detail. The other direction is + considered only useful in theoretical work. + + Because we are programming in Haskell, and not Idris, I have decided to leave some invariants + out of the type system. The documentation of 'Hexpr' and 'Quasihexpr' give these invariants. + It would make pattern matching too cumbersome to encode these invariants, and some would even + need extensions. If I were to instead hide the unsafety, it would make pattern matching + impossible. +-} +module Data.Hexpr ( + -- * Primary Data Structures + Hexpr(..) + , Quasihexpr(..) + -- * Translation + , unQuasihexpr + , UnQuasihexpr(..) + ) where + +import Data.List +import Control.Applicative + +import Data.Hierarchy + + +------ Types ------ +{-| Whereas a rose contains an element at every level of organization, elements of a hexpr appear + only in the leaves of the structure. That is, internal nodes (branches) are only responsible + for grouping consecutive elements and other groups. + + Hexprs further disallow trivial branches, where trivial means containing zero of one children. + Where there are zero children in a branch, the branch contains no information. Where a branch + contains only one node, no extra grouping information is provided. As branches are responsible + for grouping, and grouping alone, it does not make sense to allow branches that contain no + grouping structure. + These restrictions on the number of children in a branch are not currently enforced by the + type system, so several functions on hexprs are properly partial. + + To aid in production-quality language implementation, we also attach a position to each node. + If position is unneeded, simply specialize to @()@. +-} +data Hexpr p a = Leaf p a + | Branch p [Hexpr p a] + +{-| A Quasihexpr extends 'Hexpr' with quasiquotation. + + In addition to the usual restrictions on hexprs, each 'Unquote' and 'Splice' element must be + contained within a matching 'Quasiquote' ancestor. Each Quasiquote can match with multiple + (or zero) Unquote and Splice nodes, just so long as there is no other Quasiquote between. + Again, this restriction is not enforced by the type system. +-} +data Quasihexpr p a = QLeaf p a + | QBranch p [Quasihexpr p a] + | Quote p (Quasihexpr p a) + | Quasiquote p (Quasihexpr p a) + | Unquote p (Quasihexpr p a) + | Splice p (Quasihexpr p a) + + +------ Hexpr Transforms ------ +class UnQuasihexpr a where + {-| A node that, when evaluated, creates a single hexpr node from at least one code values. + + For example, create the node @('nodeForm' \ ... \)@ with @n >= 1@, such that + then if each @e_i@ reduces to a code value @v_i@, then the whole node evaluates to + @('quoteForm' (\ ... \))@. + -} + mkNode :: p -> [Quasihexpr p a] -> Quasihexpr p a + {-| A vararg function that turns a number of values into a list during evaluation. -} + mkList :: p -> [Quasihexpr p a] -> Quasihexpr p a + {-| A vararg function that concatenates lists of values into a single node where the lists are + obtained by evaluating sibling nodes. + + For example, create the node @('concatForm' \ ... \)@ with @n >= 1@, such that + if each @e_i@ reduces to a list of code values @vs_i@, then the whole form evaluates to + @('quoteForm' (\ ++ ... ++ \))@. + -} + mkConcat :: p -> [Quasihexpr p a] -> Quasihexpr p a + + isList :: Quasihexpr p a -> Bool + fromList :: Quasihexpr p a -> [Quasihexpr p a] + + removeQuotation :: Quasihexpr p a -> Hexpr p a + +{-| FIXME stale documentation + + Transform a quasihexpr into a hexpr. When the input consists only of 'QLeaf' and 'QBranch' + nodes, the transformation is trivial. However, 'Quote', 'Quasiquote', 'Unquote' and 'Splice' + need to be specially encoded. + + Of course, appropriate recursion is also needed, but for that, see the source code. It's + interesting, but not helpful for understanding the results if you already understand + quasiquotation. + + The naive algorithm would usually produce hexprs that are more complex than is necessary. + This function factors quotation and quote manipulation to eliminate redundancy. + + Assuming that 'fromQuote' does not fail in the transformations, the particular transforms made + are as follows. Appropriate recursive searches are made so that no opportunity to simplify is + lost. + + * @('mkNode' c1 ... cn)@ ---> @('mkQuote' (s1 ... sn))@ + where @si = 'fromQuote' ci@ + + * @('mkConcat' c1 ... cn)@ ---> @('mkQuote' cs)@ + where @cs = conjoins ('fromQuote' \<$\> [c1, ..., cn])@ + + TODO: The following are unimplemented, but shouldn't matter too much. + However, ideally the set of Hexprs returned from this function should be + a proper subset of Hexprs (i.e. a normal form) that is isomorphic to Quasihexpr. + Probably, once the isomorphism is proven, I'll merge this in with unQuasihexpr + + * @('nodeForm' x1 ... xm) ('quoteForm' xn)@ ---> @('nodeForm' x1 ... xm xn)@ + + * @('quoteForm' x0) ('nodeForm' x1 ... xn)@ ---> @('nodeForm' x0 x1 ... xn)@ + + * Any immediate siblings of nodeForm-lead branches are pushed into the nodeForm just so long as + the parent is not a concatForm-lead branch. +-} +unQuasihexpr :: (UnQuasihexpr a) => Quasihexpr p a -> Hexpr p a +unQuasihexpr = simplify . removeQuotation . go + where + go (QLeaf p x) = QLeaf p x + go (QBranch p xs) = QBranch p (go <$> xs) + go (Quote p x) = Quote p (go x) + go (Quasiquote q (QLeaf p x)) = Quote q (QLeaf p x) + go (Quasiquote q (QBranch p xs)) = unquasiquoteBranch q p xs + go (Quasiquote q (Quote p x)) = Quote q (Quote p (go x)) + go (Quasiquote q (Quasiquote p x)) = pushQuote q . pushQuote p $ x + go (Quasiquote q (Unquote p x)) = go x + go (Quasiquote q (Splice p x)) = go x + go (Unquote p x) = error "malformed quasiquotation" + go (Splice p x) = error "malformed quasiquotation" + unquasiquoteBranch q p xs = case groupBy splitSplices xs of + -- if xss is a singleton, it contains no splices + [xs] -> mkNode p (pushQuote q <$> xs) + xss -> mkConcat p (createSpliceList <$> xss) + where + splitSplices x y = case (x, y) of + (Splice _ _, _) -> False + (_, Splice _ _) -> False + _ -> True + createSpliceList xs = case xs of + [Splice _ x] -> go x + _ -> mkList q (pushQuote q <$> xs) + pushQuote p = go . Quasiquote p + simplify = id --STUB +--simplifyHexpr :: SimplifyHexpr a => Hexpr p a -> Hexpr p a +--simplifyHexpr x = error "TODO" + --case x of + -- Leaf p x -> Leaf p x + -- Branch p (x:[]) -> simplifyHexpr x + -- Branch p (q:[x]) | q == Leaf quoteForm -> toCode' $ simplifyHexpr x + -- Branch p (n:xs) | n == Leaf nodeForm -> + -- let xs' = simplifyHexpr <$> xs + -- in if isCode' `all` xs' + -- then toCode' . simplifyHexpr . Branch p $ fromCode' <$> xs' + -- else conjoin p n (Branch xs') + -- Branch p (c:xs) | c == Leaf concatForm -> + -- let xs' = simplifyHexpr <$> xs + -- in if isCode' `all` xs' + -- then toCode' $ conjoins (fromCode' <$> xs') + -- else conjoin p c (Branch xs') + -- Branch p xs -> Branch p (simplifyHexpr <$> xs) + --where + --isCode' (Leaf p x) = isCode x + --isCode' _ = False + --toCode' = Leaf . toCode + --fromCode' (Leaf p x) = fromCode x + +------ Instances ------ +instance Eq a => Eq (Hexpr p a) where + (Leaf _ x) == (Leaf _ y) = x == y + (Branch _ xs) == (Branch _ ys) = xs == ys + _ == _ = False +instance Eq a => Eq (Quasihexpr p a) where + (QLeaf _ x) == (QLeaf _ y) = x == y + (QBranch _ xs) == (QBranch _ ys) = xs == ys + (Quote _ x) == (Quote _ y) = x == y + (Quasiquote _ x) == (Quasiquote _ y) = x == y + (Unquote _ x) == (Unquote _ y) = x == y + (Splice _ x) == (Splice _ y) = x == y + _ == _ = False + +--TODO this won't work if there's internal structure in the Leaves +--perhaps if I use `toCode :: Hexpr a -> Hexpr a`, then we needn't worry about internal structure so much` +instance Functor (Hexpr p) where + fmap f (Leaf p x) = Leaf p (f x) + fmap f (Branch p xs) = Branch p $ (map . fmap) f xs + +instance Functor (Quasihexpr p) where + fmap f (QLeaf p x) = QLeaf p (f x) + fmap f (QBranch p xs) = QBranch p $ (map . fmap) f xs + fmap f (Quote p x) = Quote p (fmap f x) + fmap f (Quasiquote p x) = Quasiquote p (fmap f x) + fmap f (Unquote p x) = Unquote p (fmap f x) + fmap f (Splice p x) = Splice p (fmap f x) + +instance Hierarchy Hexpr p where + getPos (Leaf p _) = p + getPos (Branch p _) = p + + individual = Leaf + + conjoin p (Branch _ as) (Branch _ bs) = Branch p $ as ++ bs + conjoin p (Branch _ as) b = Branch p $ as ++ [b] + conjoin p a (Branch _ bs) = Branch p $ [a] ++ bs + conjoin p a b = Branch p $ [a] ++ [b] + + adjoinsl p x [] = x + adjoinsl p x xs = Branch p (x:xs) + +instance Hierarchy Quasihexpr p where + getPos (QLeaf p _) = p + getPos (QBranch p _) = p + getPos (Quote p _) = p + getPos (Quasiquote p _) = p + getPos (Unquote p _) = p + getPos (Splice p _) = p + + individual = QLeaf + + conjoin p (QBranch _ as) (QBranch _ bs) = QBranch p $ as ++ bs + conjoin p (QBranch _ as) b = QBranch p $ as ++ [b] + conjoin p a (QBranch _ bs) = QBranch p $ [a] ++ bs + conjoin p a b = QBranch p $ [a] ++ [b] + + adjoinsl p x [] = x + adjoinsl p x xs = QBranch p (x:xs) + +instance Openable (Hexpr p) where + openAp (f, _) (Leaf p x) = Leaf p (f x) + openAp (_, f) (Branch p xs) = adjoins p (f xs) + +instance Openable (Quasihexpr p) where + openAp (f, _) (QLeaf p x) = QLeaf p (f x) + openAp (_, f) (QBranch p xs) = adjoins p (f xs) + openAp fs (Quasiquote p x) = Quasiquote p (openAp fs x) + openAp fs (Unquote p x) = Unquote p (openAp fs x) + openAp fs (Splice p x) = Splice p (openAp fs x) + + + + diff --git a/Data/Hierarchy.hs b/Data/Hierarchy.hs new file mode 100644 --- /dev/null +++ b/Data/Hierarchy.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| The intuition behind a hierarchy is that individuals may form groups, and groups may form groups, + but no group can have zero individuals under its umbrella. + + There are two main ways hierarchies can form (beyond just being an individual). + + * Two or more groups can merge together (conjoin), forming one group where there + were many before. + + * Two or more groups can join up underneath a new group, forming /n+1/ groups where + there were /n/ before. + + These are the intuitions behind the two relations that hierarchies support. + +-} +module Data.Hierarchy ( + Hierarchy(..) + , Openable(..) + , OpenAp + , adjoinPos, adjoinslPos, adjoinsrPos, adjoinsPos + , conjoinPos, conjoinslPos, conjoinsrPos, conjoinsPos + ) where + +{-| A hierarchy is a set, together with an associative operation and a non-associative operation, + as well as a duality law, which we'll get to after introducing the notation. + + Although we also provide for source positions, we will omit them for simplicity in this + description. + + Ideally, I'd call the associative operation @++@ or @\<\>@, but the cool infix operators are + spoken for already, so I'll have to go with descriptive names. + Raising items into the hierarchy is done with 'individual'. + We call the associative operation 'conjoin' + and the non-associative @adjoins@. + + In fact, there are two adjoins, 'adjoinsl' and 'adjoinsr'. Offering only these means we can + satisfy the invariant that groups recursively have at least one individual. In the discussions + below, assume that @adjoins@ is of type @[f a] -> [f a] -> f a@, and that when called, at least + one of the arguments is non-empty. + + The names literally mean \"join together\" and \"join to\", which succinctly convey the + associativity properties of each. Well, \"join to\" might seem non-specific, but consider + building a house in the wrong order as opposed to joining several cups of water in the wrong + order. \"Ad-\" and \"con-\" have these meanings, even if the prepositions I've used as + translation aren't so fine-grained. + + The duality law is: + + @ + a `conjoin` (b `adjoin` c) === (a `adjoin` b) `conjoin` c + @ + + The minimal implementation is 'individual', 'conjoin', and 'adjoinsl'. + + Some hierarchies may be commutative in conjoin and/or adjoin. For example, file systems + (ignoring links) are hierarchies: adjoin creates new directories (though it is not + the only way), and 'conjoin' adds files/directories into an existing directory, or creates a + new two-element directory. Clearly, conjoin is commutative here. For generality, we have + given default implemetations assuming non-commutativity in both operations. +-} +class Hierarchy h p where + getPos :: h p a -> p + + individual :: p -> a -> h p a + + adjoin :: p -> h p a -> h p a -> h p a + adjoin pos a b = adjoinsl pos a [b] + + adjoinsl :: p -> h p a -> [h p a] -> h p a + + adjoinsr :: p -> [h p a] -> h p a -> h p a + adjoinsr pos [] a = a + adjoinsr pos (a:as) b = adjoinsl pos a (as++[b]) + + adjoins :: p -> [h p a] -> h p a + adjoins pos [] = error "Cannot construct hierarchy of zero elements." + adjoins pos (x:xs) = adjoinsl pos x xs + + conjoin :: p -> h p a -> h p a -> h p a + + conjoinsl :: p -> h p a -> [h p a] -> h p a + conjoinsl pos acc [] = acc + conjoinsl pos acc (x:xs) = conjoinsl pos (conjoin pos acc x) xs + + conjoinsr :: p -> [h p a] -> h p a -> h p a + conjoinsr pos [] base = base + conjoinsr pos (x:xs) base = conjoin pos (conjoinsl pos x xs) base + + conjoins :: p -> [h p a] -> h p a + conjoins pos [] = error "Cannot construct hierarchy of zero elements." + conjoins pos (x:xs) = conjoinsl pos x xs + + +adjoinPos :: (Hierarchy h p) => h p a -> h p a -> h p a +adjoinPos x y = adjoin (getPos x) x y +adjoinslPos :: (Hierarchy h p) => h p a -> [h p a] -> h p a +adjoinslPos x [] = x +adjoinslPos x ys = adjoinsl (getPos x) x ys +adjoinsrPos :: (Hierarchy h p) => [h p a] -> h p a -> h p a +adjoinsrPos [] x = x +adjoinsrPos xs y = adjoinsr (getPos $ head xs) xs y +adjoinsPos :: (Hierarchy h p) => [h p a] -> h p a +adjoinsPos [] = error "Cannot construct hierarchy of zero elements." +adjoinsPos (x:xs) = adjoinslPos x xs +conjoinPos :: (Hierarchy h p) => h p a -> h p a -> h p a +conjoinPos x y = conjoin (getPos x) x y +conjoinslPos :: (Hierarchy h p) => h p a -> [h p a] -> h p a +conjoinslPos acc [] = acc +conjoinslPos acc (x:xs) = (acc `conjoinPos` x) `conjoinslPos` xs +conjoinsrPos :: (Hierarchy h p) => [h p a] -> h p a -> h p a +conjoinsrPos [] base = base +conjoinsrPos (x:xs) base = (x `conjoinslPos` xs) `conjoinPos` base +conjoinsPos :: (Hierarchy h p) => [h p a] -> h p a +conjoinsPos [] = error "Cannot construct hierarchy of zero elements." +conjoinsPos (x:xs) = conjoinslPos x xs + + +{-| It is often useful to look at the elements of a node in a 'Hierarchy', perform + some transformation, then package the result back up as it was originally. Openable + provides exactly the required functionality. This may be useful more generally as + well, so we provide it as an independent class that can operate on structures that + have leaves and/or branches. + + The minimal complete implementation is 'openAp'. +-} +class Openable f where + {-| Open a node, perform either the leaf or branch transform and close it back up. + + This algorithm should not recursively traverse the structure. Thus, even if the + structure consists only of leaves, 'openAp' is /not/ a fancy way to say 'fmap'. + -} + openAp :: OpenAp f a -> f a -> f a + + {-| Perform a preorder traversal version of 'openAp'. -} + preorder :: OpenAp f a -> f a -> f a + preorder f x = (id, fmap $ preorder f) `openAp` (f `openAp` x) + + {-| Perform a postorder traversal version of 'openAp'. -} + postorder :: OpenAp f a -> f a -> f a + postorder f x = f `openAp` ((id, fmap $ postorder f) `openAp` x) + +{-| Package a transformations for leaves and branches together. -} +type OpenAp f a = (a -> a, [f a] -> [f a]) + diff --git a/Data/Sexpr.hs b/Data/Sexpr.hs new file mode 100644 --- /dev/null +++ b/Data/Sexpr.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +module Data.Sexpr ( + Sexpr(..) + , SexprToHexpr(..) + , sexprToHexpr + ) where + +import Data.Hierarchy +import Data.Hexpr + + +data Sexpr p a = Atom p a | Sexpr p [Sexpr p a] + +instance Hierarchy Sexpr p where + getPos (Atom p _) = p + getPos (Sexpr p _) = p + + individual = Atom + + conjoin p (Sexpr _ as) (Sexpr _ bs) = Sexpr p (as++bs) + conjoin p a (Sexpr _ bs) = Sexpr p (a:bs) + conjoin p (Sexpr _ as) b = Sexpr p (as++[b]) + conjoin p a b = Sexpr p [a, b] + + adjoinsl p x xs = Sexpr p (x:xs) + + adjoins = Sexpr + +instance Openable (Sexpr p) where + openAp (f, _) (Atom p x) = Atom p (f x) + openAp (_, f) (Sexpr p xs) = Sexpr p (f xs) + + +class SexprToHexpr a where + xformNull :: p -> Hexpr p a + xformNull = error "Empty sexprs are disallowed" + xformSingleton :: Sexpr p a -> Hexpr p a + + xformDeepAtom :: a -> a + xformDeepAtom = id + +sexprToHexpr :: (SexprToHexpr a) => Sexpr p a -> Hexpr p a +sexprToHexpr (Atom p x) = Leaf p (xformDeepAtom x) +sexprToHexpr (Sexpr p []) = xformNull p +sexprToHexpr (Sexpr p [x]) = xformSingleton x +sexprToHexpr (Sexpr p xs) = Branch p (map sexprToHexpr xs) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Zankoku Okuno + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Zankoku Okuno nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Desugar.hs b/Language/Desugar.hs new file mode 100644 --- /dev/null +++ b/Language/Desugar.hs @@ -0,0 +1,118 @@ +module Language.Desugar ( + -- * List Splitting + tripBy + , revTripBy + , SplitFunction + -- * Implicit Parenthesis + , addParens + , addShortParens + -- * Simple Infixes + , forwardInfix + , reverseInfix + ) where + +import Data.List +import Data.Hierarchy +import Data.Hexpr + + +{-| Transform a list based on the presence and location of an element. + + The first function of the pair is applied when no element was found. + Its parameter is the original list. + + The second of the pair is applied with an element is found. + Its parameters are (in order) the preceding elements, the found element, and the + following elements. +-} +type SplitFunction a b = ([a] -> b, [a] -> a -> [a] -> b) + +{-| Split a list at the first element that matched the predicate. + If the element was not found, apply the 'SplitFunction'. +-} +tripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b +tripBy p (onNo, onYes) xs = case break p xs of + (before, []) -> onNo xs + (before, x:after) -> onYes before x after + +{-| As 'tripBy', but search from the end. +-} +revTripBy :: (a -> Bool) -> SplitFunction a b -> [a] -> b +revTripBy p (onNo, onYes) xs = case revBreak p xs of + (before, []) -> onNo xs + (before, after) -> onYes (init before) (last before) (after) + +revBreak p xs = let (rAfter, rBefore) = break p (reverse xs) + in if null rBefore + then (reverse rAfter, []) + else (reverse rBefore, reverse rAfter) + +{-| Create a group around a found subnode and all following nodes. + If no node was found, then there is no change. + + E.g +@ + (a b lambda x y z) ===> (a b (lambda x y z)) +@ +-} +addParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a +addParens p = (id, tripBy p (id, onYes)) + where + onYes before x after = before ++ [x `adjoinslPos` after] + +{-| Add parenthesis around a found subnode and at most one following node. + Associates to the right. + If no node was found, then there is no change. + + E.g. +@ + (++ ++ x) ===> (++(++(x))) +@ +-} +addShortParens :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> h p a -> h p a +addShortParens p = openAp (id, tripBy p (id, onYes)) + where + onYes before x [] = before++[x] + onYes before x after' = case span p after' of + ([], []) -> [x] + (cont, []) -> before++[deepen (last cont) (reverse (x:init cont))] + (cont, next:after) -> before ++ [deepen next (reverse (x:cont))] ++ after + where + deepen acc [] = acc + deepen acc (x:xs) = deepen (x `adjoinPos` acc) xs + + +{-| Given an infix-detecting predicate, find the first matching subnode in the given node. + Move the matching node to the front and wrap either side in new subnodes. If there is + no matching subnode or either side is missing, the node is returned unchanged. + + E.g. +@ + (a b + c d + e f) ===> (+ (a b) (c d + e f)) +@ +-} +forwardInfix :: (Openable (h p), Hierarchy h p) => (h p a -> Bool) -> OpenAp (h p) a +forwardInfix p = (id, tripBy p (id, onYes)) + where + onYes [] x after = x:after + onYes before x [] = before++[x] + onYes before x after = [x, adjoinsPos before, adjoinsPos after] + +{-| Given an infix-detecting predicate, find the last matching subnode in the given node. + Move the matching node to the front and wrap either side in new subnodes. If there is + no matching subnode or either side is missing, the node is returned unchanged. + +@ + (a b ** c d ** e f) ===> (** (a b ** c d) (e f)) +@ +-} +reverseInfix :: (Openable (h p), Hierarchy h p, Show (h p a)) => (h p a -> Bool) -> OpenAp (h p) a +reverseInfix p = (id, revTripBy p (id, onYes)) + where + onYes [] x after = x:after + onYes before x [] = before++[x] + onYes before x after = [x, adjoinsPos before, adjoinsPos after] + + + + diff --git a/Language/Distfix.hs b/Language/Distfix.hs new file mode 100644 --- /dev/null +++ b/Language/Distfix.hs @@ -0,0 +1,437 @@ +{-| We present an algorithm for de-sugaring distributed affixes (/distfixes/) in a rose-like data + structure. Distfixes are also known as /mixfixes/, but I chose /dist-/ because the parts of + the affix are distributed in-order through the root, rather than mixed in (out-of-order + connotation) with the root. Now then, let's actually describe a distfix in detail: + + By /rose-like/ data structure, we mean any type @t@ such that when an element of @t@ can be + 'unwrap'ped into a @[t]@, we can perform rewrites according to our distfix algorithm + and 'rewrap' the result. If a particular element cannot be 'unwrap'ped, then it will be + left alone during rewriting. Of course, this library was meant to operate on 'Hexprs' and + 'Quasihexprs', but it could just as well work on a plain list or rose, as well as anything else + you're willing to mangle into shape. + + A distributed affix consists of a number of alternating /keywords/ and /slots/. While keywords + should match exactly one leaf node, slots can consume multiple nodes (leaves or branches) + during a detection. If we denote slots by underscores and keywords by some reasonable + programming language identifier (w/o underscores), then some representative distfix examples + might be @_+_@, @_?_:_@, @_!@, @if_then_else_@, and @while_do_end@. + + Using the algorithm requires categorizing the input distfixes in several dimensions: + /topology/, /associativity/, /priority/, and /precedence/. Only precedence need by specified by + the user (it is extrinsic to any distfix), the rest are either specified in or calculated from + the distfix at hand. We discuss these properties below: + + Slots in a distfix are always separated by keywords, but they may also be a leading and/or + trailing keyword in a distfix. The presence or absence of certain keywords is the + /topology/ of a distfix, and this affects the possibilities of its /associativity/. + There are four options: + + * /Closed/: preceded and followed by keywords (e.g. @begin_end@) + + * /Half-open Left/: only followed by a keyword (e.g. @_!@) + + * /Half-open Right/: only preceded by a keyword (e.g. @if_then_else_@) + + * /Open/: neither preceded nor followed by a keyword (e.g. @_+_@) + + As usual, there are three /associativities/: /left-/, /right-/, and /non-associative/. Open + distfixes can take any of these three. Closed distfixes have no associativity. Half-open left + distfixes are always left associative, and half-open right are always right associative. + + Operators are divided into /precedence/ levels as normal, but there are no limits on the number + of precedence levels available for use. In the distfix table, groups of distfixes of the same + precedence are sorted in descending order. + + When given a list of expressions (the contents of an 'unwrap'ped node) and a distfix, the + distfix may be /detected/ within the list. When multiple distfixes in a single precedence + level are detected at once, an attempt is made to /select/ exactly one of the detected + distfixes using a /priority scheme/ calculated from the properties of the distfixes in + question. Provided that one distfix has a higher priority than all the other detected + distfixes, the highest priority distfix binds least tightly (and is therefore selected first). + + The rules for calculating priority are these: + + * If both distfixes have the same associativity (left- or right-, but not non-associative), + the one with the \"most significant\" keyword \"earliest\" has priority: + for left-associative, most significant means first and earliest means leftmost; + for right-associative, most significant means last, earliest means rightmost. + If its a still a tie, then the one with the most keywords has priority. + + * If both distfixes are closed, then they must be non-overlapping, or one must contain the + other. + It doesn't really matter which has higher priority if they don't overlap + (as it happens, we've chosen leftmost for now). + If one nests within the other, the outer has priority. + If they overlap exactly, then the one with the most keywords has priority. + + * Other pairs of matches have no priority distinction. + + Given that a particular distfix is detected and selected for rewriting, we rewrite the list of + terms by /extracting/ the distfix from its slots. Specifically, we take the detected elements + and run them through the distfix's /rewriter/ to produce some single element. We then place the + rewritten element at the front of the node, followed by each (filled) slot in order and + 'rewrap'ped in its own node. The re-written list is finally 'rewrap'ped and placed back in + its original context. + + Detections are made recursively. The details are unimportant except that this algorithm is + applied at every branch in the structure /as made available/ by 'unwrap' and the recursion + respects precedence and priority. Each branch is assumed to have been enclosed by parenthesis + during parsing, and therefore 'unwrap'ping resets the precedence level. Note that rewriting + only adds branches to the structure, never removes them, and so we can see distfixes as + adding implicit parenthesis, which can be quite valuable as a conservative tool for + increasing the signal-to-noise ratio in a programming language. + + Now for some technical notes: + + I'm not sure how detection and priority will work if the same keyword appears twice in the same + distfix, so it's probably best to avoid that for now. Or work it out and tell me, whatever. + Either someone will eventually need this, at which point we'll deal with it, or maybe I'll get + bored, or maybe I just won't care enough relative to other problems. + + The two-typeclass system might seem a bit strange, but this is so I can avoid making the user + involve ghc's @FlexibleInstances@ extension. So, give an instance for + @'DistfixElement' SomeType@ and @'DistfixElement' a => 'DistfixStructure' ('Hexpr' a)@, with + 'nodeMatch' simply unwrapping 'Leaf' and delegating to 'match'. +-} +module Language.Distfix ( + -- * Data Structures + Distfix(..) + , Shape(..) + , DistfixTable + -- * Classes + , DistfixStructure(..) + , DistfixElement(..) + -- * User Space + , runDistfix + , DistfixError(..) + ) where + +import Data.Ord +import Data.List +import Data.Maybe +import Data.Either +import Control.Applicative +import Control.Monad + + +------ Types ------ +{-| These data structures can be de-structured in a rose-like fashion. See the module description + for detail on the meaning of \"rose-like\". + + There is one law: + + [Inverse] @maybe node (\(xs, rewrap) -> rewrap xs) (unwrap node) === node@ + + In other words, if you can unwrap a node, then rewrapping will perform the inverse. +-} +class DistfixStructure f where + {-| Unpack a branch node into a list of that branch's children + and a rewrapping function. -} + unwrap :: f -> Maybe ([f], [f] -> f) + + {-| Workaround so I can give an instance of Show (DistfixError a). + -} + defaultRewrap :: [f] -> f + + {-| Whereas 'match' operates on elements of the structure, 'nodeMatch' is really just + boilerplate that extracts an element and calls 'match' on it. + + For example, we might write + +@ + instance 'DistfixDetect' a => 'DistfixStructure' ('Hexpr' a) + nodeMatch ('Leaf' x) ('Leaf' y) = match x y + nodeMatch _ _ = False +@ + + Very probably, it would not make sense to allow a non-leaf node to match anything (by + implication, disallowing non-leaf keywords). + -} + nodeMatch :: f -> f -> Bool +{-| This class is used for matching instead of 'Eq' so that certain components of the data might be + ignored. For example, if @a = (SourcePos, b)@ then the @SourcePos@ should clearly be ignored + during matching. +-} +class DistfixElement a where + {-| Whether the two elements are equal with respect to matching a keyword. -} + match :: a -> a -> Bool + +{-| A distfix consists of + 1) a rewriter, the results of which precede the slots when extracting, + 2) a topology and associativity, which is actually merged into a single datatype 'Shape' + because the choice of associativity is not independent of topology, and + 3) a non-empty list of keywords, each implicitly separated by a slot. + + In case a distfix has a closed topology, its list of keywords must actually be at least two + elements long (one for the open keyword, and one for the close keyword). + + For more detail on these components, see the module documentation. +-} +data Distfix a = Distfix ([a] -> a) Shape [a] +{-| Information on both topology and associativity. + + The two properties are merged into one datatype because choice of one limits choice of the + other. The constructors should make the possibilities clear enough, but the module + documentation might better present the reasoning involved. +-} +data Shape = Closed | HalfOpenRight | HalfOpenLeft | OpenRight | OpenLeft | OpenNon + deriving (Eq, Show) + +{-| A list, in descending order of precedence (ascending of binding tightness) of groups of + Distfixes. + + How tightly distfixes within a group bind relative to one another is determined by priority + (see the module description). Although ambiguous grammars are accepted, it might be best to + avoid forcing the user to make lots of priority calculations just to determine if they need to + insert disambiguating parenthesis. +-} +type DistfixTable a = [[Distfix a]] + +newtype Detection a = Detection { unMatch :: (Distfix a, [a], [a], [[a]], [a]) } +data MatchResult a = NoMatch + | OneMatch (Detection a) + | Ambiguous [Detection a] +type DistfixResult a = DistfixResult' a a +-- I only threw @DistfixResult'@ in here so I can make a monad. @DistfixResult@ is the more important one +newtype DistfixResult' e a = Result { unResult :: Either (DistfixError e) a } + +{-| Report reasons for error in recognizing distfixes. There are two causes of error: + + [Ambiguity] When there is no single detection that has higher precedence or priority within a + set of detections made in a node, this is an ambiguous parse. Note that ambiguous grammars are + allowed in this scheme, but should this ambiguity manifest itself in an input, that input is + not recognized. Really, this is pretty spiffy: distfixes admit specification fairly near to an + arbitrary context-free grammar, but the algorithm will excise ambiguity only where it needs to, + completely side-stepping the problem of whether a given grammar is ambiguous. + + [Leftovers] Once we've detected all the keywords possible in a node, we need to ensure there + are no leftover keywords. If there were, this would probably indicate a user forgetting a + keyword. For example, suppose @[|_|]@ were a distfix then @[| a ]@ would obtain a LeftoverErr. + + There's some fuzziness between 'AmbiguousErr' and 'LeftoverErr'. To illustrate, suppose we have + @_<_@ and @_<=_@ but not @_<=_<_@ as a distfix, then both @a < b < c@ and @a <= b < c@ will be + errors. The first will result in leftovers, and the second in ambiguity. It would make sense if + they were both 'AmbiguousErr', but doing so under the current structure would sacrifice some + efficiency (and possibly complicate matters). Still, at least everything that /should/ be an + error /is/ an error. +-} +data DistfixError a = AmbiguousErr [(Distfix a, [a], [a], [[a]], [a])] + | LeftoverErr [a] + + +------ Instances ------ +instance (Show a, DistfixStructure a) => Show (DistfixError a) where + show (AmbiguousErr matches) = headText ++ concatMap makeLine matches + where + headText = "Ambiguous distfix parse. Could have been one of:" + makeLine = ("\n\t"++) . show . right . extract (return . defaultRewrap) defaultRewrap . Detection + right (Result (Right x)) = x + show (LeftoverErr [k]) = "Leftover keyword: " ++ show k + show (LeftoverErr ks) = "Leftover keywords:" ++ concatMap ((' ':) . show) ks + + +------ Main Algorithm ------ +{-| Given a table of distfixes and some input structure, apply the distfix detection/extraction + algorithm. + + The algorithm may fail with a 'DistfixError'. The module description explains successful + results in more detail. +-} +runDistfix :: DistfixStructure a => DistfixTable a -> a -> Either (DistfixError a) a +runDistfix table x = case unwrap x of + Nothing -> return x + Just (xs, rewrap) -> mapM (runDistfix table) xs >>= unResult . (impl rewrap table) + where + impl rewrap [] xs = findLeftovers rewrap allKeywords xs + impl rewrap table'@(row:rows) xs = case select row xs of + NoMatch -> impl rewrap rows xs + OneMatch op -> extract (impl rewrap table') rewrap op + Ambiguous ops -> Result . Left . AmbiguousErr $ fmap unMatch ops + allKeywords = nubBy nodeMatch . (concatMap . concatMap) (\(Distfix _ _ ks) -> ks) $ table + +{-| It's a pretty weird mutual-recursion thing going on between runDistfix.impl and extract. + See, we obviously have to recurse on the inner nodes, but then we also need to recurse on the + reconstructed node, in case of nodes like `a + if p then conseq else alt` + + I'm basically passing in `recurse` as a specialized delimited continuation. There's another + function that uses extract, so I couldn't just put extract in the closure with impl. + I'm pretty sure it's necessary to pass the recursion in anyway (but I can't remember why). +-} +extract :: DistfixStructure a => ([a] -> DistfixResult a) -> ([a] -> a) -> Detection a -> DistfixResult a +extract recurse rewrap (Detection (Distfix rewrite _ _, found, before, inside, after)) = do + inside' <- rewrap . (rewrite found:) <$> mapM recurse inside + recurse $ before ++ [inside'] ++ after + + +------ Selection ------ +{-| Given a bunch of distfixes (at the same precedence level), try to find an unambiguous distfix + parse within a list. +-} +select :: DistfixStructure a => [Distfix a] -> [a] -> MatchResult a +select ops xs = impl detectAll [] + where + detectAll = catMaybes $ map (detect xs) ops + impl [] eqSet = case eqSet of + [] -> NoMatch + [x] -> OneMatch x + xs -> Ambiguous xs + impl (x:xs) eqSet = if is Lower then impl xs eqSet + else if is Higher then impl xs [x] + else impl xs (x:eqSet) + where is = (`elem` map (decidePriority x) eqSet) + +{-| Given two detections, give the relative priority of the first to the second. -} +decidePriority :: Detection a -> Detection a -> Priority +decidePriority a@(Detection (Distfix _ topA ksA, _, bA, iA, aA)) b@(Detection (Distfix _ topB ksB, _, bB, iB, aB)) = case (topA, topB) of + (OpenLeft, OpenLeft) -> decideLeft + (OpenLeft, HalfOpenLeft) -> decideLeft + (HalfOpenLeft, OpenLeft) -> decideLeft + (HalfOpenLeft, HalfOpenLeft) -> decideLeft + (OpenRight, OpenRight) -> decideRight + (OpenRight, HalfOpenRight) -> decideRight + (HalfOpenRight, OpenRight) -> decideRight + (HalfOpenRight, HalfOpenRight) -> decideRight + (Closed, Closed) -> decideClosed + (Closed, _) -> Higher + (_, Closed) -> Lower + _ -> Same + where + decideRight = leftmost `joinPriority` mostKeywords + where leftmost = fromOrd . negOrd $ comparing leftmostKeyword a b + decideLeft = rightmost `joinPriority` mostKeywords + where rightmost = fromOrd $ comparing rightmostKeyword a b + decideClosed = leftmostNoOverlap `joinPriority` outermost `joinPriority` (if exactOverlap then mostKeywords else Same) + where + leftmostNoOverlap = if aR < bL then Higher else if bR < aL then Lower else Same + outermost = case (compare aL bL, compare aR bR) of + (LT, GT) -> Higher -- `a b b a` + (GT, LT) -> Lower -- `b a a b` + (LT, EQ) -> Higher -- `a b ab` + (GT, EQ) -> Lower -- `b a ab` + (EQ, LT) -> Lower -- `ab a b` + (EQ, GT) -> Higher -- `ab b a` + _ -> Same + exactOverlap = aL == bL && aR == bR + aL = leftmostKeyword a + aR = rightmostKeyword a + bL = leftmostKeyword b + bR = rightmostKeyword b + mostKeywords = fromOrd $ comparing impl a b + where impl (Detection (Distfix _ _ ks, _, _, _, _)) = length ks + -- index of leftmost keyword in the original node + leftmostKeyword (Detection (Distfix _ OpenRight _, _, _, inside, _)) = length (head inside) + leftmostKeyword (Detection (Distfix _ HalfOpenRight _, _, before, _, _)) = length before + leftmostKeyword (Detection (Distfix _ Closed _, _, before, _, _)) = length before + -- index of rightmost keyword in the original node + rightmostKeyword (Detection (Distfix _ OpenLeft _, _, _, inside, _)) = sum (map length $ init inside) + (length (init inside) - 1) + rightmostKeyword (Detection (Distfix _ HalfOpenLeft _, _, _, inside, _)) = sum (map length inside) + (length inside - 1) + rightmostKeyword (Detection (Distfix _ Closed _, _, before, inside, _)) = length before + sum (map length inside) + length inside + + +------ Detection ------ +{-| Once all possible detections have been found in a node, use this to repack. -} +findLeftovers :: DistfixStructure a => ([a] -> a) -> [a] -> [a] -> DistfixResult a +findLeftovers rewrap ks xs = case filter (\x -> nodeMatch x `any` ks) xs of + [] -> Result . Right . rewrap $ xs + errs -> Result . Left $ LeftoverErr errs + +{-| FIXME MAYBE This guy ignores the possibility of several matches of the same keyword, which may + lead to weird error messages? Not sure, but if weird error messages don't haunt us, this is + more efficient by a fair margin. +-} +detect :: DistfixStructure a => [a] -> Distfix a -> Maybe (Detection a) +detect xs fix@(Distfix _ topology ks) = do + when (length ks == 0) $ error "distfixes must have at least one keyword" + (found, before, inside, after) <- case topology of + Closed -> do + when (length ks < 2) $ error "closed distfixes must have at least two keywords" + (as, kw1, ds) <- findKey (head ks) xs + (cs, kw, bs) <- revFindKey (last ks) ds + (kws, res) <- detectBody (init . tail $ ks) cs + Just ([kw1]++kws++[kw], as, res, bs) + HalfOpenRight -> do + (as, kw1, bs) <- findKey (head ks) xs + (kws, res) <- detectBody (tail ks) bs + Just ([kw1]++kws, as, res, []) + HalfOpenLeft -> do + (as, kw, bs) <- revFindKey (last ks) xs + (kws, res) <- revDetectBody (init ks) as + Just (kws++[kw], [], res, bs) + OpenRight -> do + (as, kw1, bs) <- findKey (head ks) xs -- find the first one, so the following ones get wrapped in implicit parens + (kws, res) <- detectBody (tail ks) bs + Just ([kw1]++kws, [], as:res, []) + OpenLeft -> do + (as, kw, bs) <- revFindKey (last ks) xs -- find the last one, so the preceding ones get wrapped in implicit parens + (kws, res) <- revDetectBody (init ks) as + Just (kws++[kw], [], res++[bs], []) + OpenNon -> do + (as, kw1, bs) <- findKey (head ks) xs + (kws, res) <- detectBody (tail ks) bs + if isJust $ detect (last res) fix + then Nothing + else Just ([kw1]++kws, [], as:res, []) + if null `any` inside + then Nothing + else Just $ Detection (fix, found, before, inside, after) + +{-| recognize keyword-slot pairs left-to-right, so use as a continuation after stripping away leading/trailing keywords -} +detectBody :: DistfixStructure a => [a] -> [a] -> Maybe ([a], [[a]]) +detectBody ks xs = impl ks xs [] [] + where + impl [] xs kws xss = Just (reverse kws, reverse (xs:xss)) + impl (k:ks) xs kws xss = do + (as, kw, bs) <- findKey k xs + impl ks bs (kw:kws) (as:xss) +{-| as detect body, but right-to-left, for left-associative things -} +revDetectBody :: DistfixStructure a => [a] -> [a] -> Maybe ([a], [[a]]) +revDetectBody ks xs = do + (kws, xss) <- impl (reverse ks) (reverse xs) [] [] + return (kws, map reverse xss) + where + impl [] xs kws xss = Just (reverse kws, reverse (xs:xss)) + impl (k:ks) xs kws xss = do + (bs, kw, as) <- findKey k xs + impl ks bs (kw:kws) (as:xss) + +{-| Get the parts of a list (before, after) the given keyword. Start from the left. -} +findKey :: DistfixStructure a => a -> [a] -> Maybe ([a], a, [a]) +findKey kw xs = case nodeMatch kw `break` xs of + res@(_, []) -> Nothing + (before, (k:after)) -> Just (before, k, after) +{-| As findKey, but start from right. -} +revFindKey :: DistfixStructure a => a -> [a] -> Maybe ([a], a, [a]) +revFindKey kw xs = do + (b,k,a) <- findKey kw (reverse xs) + return (reverse a, k, reverse b) + + +------ Helpers ------ +{-| if the first way of determining priority works, take it, otherwise try the second way -} +joinPriority :: Priority -> Priority -> Priority +joinPriority Same y = y +joinPriority x _ = x + +data Priority = Higher | Lower | Same deriving (Eq) +fromOrd LT = Lower +fromOrd EQ = Same +fromOrd GT = Higher + +negOrd :: Ordering -> Ordering +negOrd LT = GT +negOrd EQ = EQ +negOrd GT = LT + +instance Functor (DistfixResult' e) where + fmap = liftM + +instance Applicative (DistfixResult' e) where + pure = return + (<*>) = ap + +instance Monad (DistfixResult' e) where + return = Result . Right + (Result x) >>= k = Result (x >>= unResult . k) + +instance (Show a) => Show (Distfix a) where + show (Distfix _ shape x) = "Distfix " ++ show shape ++ " " ++ show x diff --git a/Language/Parse.hs b/Language/Parse.hs new file mode 100644 --- /dev/null +++ b/Language/Parse.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE FlexibleContexts #-} +{-| Utility library that provides parsers for commonly-occuring programming + constructs such as identifiers, numbers and characters. +-} +module Language.Parse ( + -- * Combinators + -- ** Composable + string + , lookAhead + , manyTill + , manyThru + , (<|>) + , choice + -- ** Extra + , many2 + , between2 + , isEof + , spaces1 + , charICase + , stringICase + -- * Identifiers + , blacklistChar + -- * Numbers + -- ** Prepackaged Parsers + , anyNumber + -- ** Number Parts + , signLiteral + , baseLiteral + , naturalLiteral + , mantissaLiteral + , exponentLiteral + , denominatorLiteral + , xDigit + -- ** Convert Strings to Numbers + , stringToInteger + , stringToMantissa + -- * Characters + , literalChar + , maybeLiteralChar + ) where + +import Control.Monad +import Control.Applicative ((<$>), (<*>), (*>), (<*)) + +import Data.Maybe +import Data.Ratio +import Data.Char +import Text.Parsec ( ParsecT + , satisfy, char, oneOf, eof + , try, (), parserZero) +import qualified Text.Parsec as P + + + +--FIXME put this in Parsec.Combinators.Composable +------ Composable Combinators ------ +{-| Parse a string, but don't consume input on failure. -} +string :: (Monad m, P.Stream s m Char) => String -> ParsecT s u m String +string = try . P.string + +{-| Lookahead without consuming any input. -} +lookAhead :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a +lookAhead = try . P.lookAhead + +{-| Use @manyTill p e@ to apply parser @p@ many times, stopping as soon as + @e@ is next to parse. Note that @e@ is not consumed. +-} +manyTill :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a] +manyTill p e = P.manyTill p (lookAhead e) + +{-| Use @manyThru p e@ to apply parser @p@ many times, stopping as soon as + @e@ is consumed. Unlike Parsec's @manyTill@, if @e@ fails, it does not + consume input. +-} +manyThru :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m [a] +manyThru p e = P.manyTill p (try e) + +{-| Use @a <|> b@ to parse @a@ or @b@. If @a@ fails, no input is consumed. -} +(<|>) :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a +a <|> b = try a P.<|> b + +{-| Parse the first of the passed combinators that succeeds. If any + parser fails, it does not consume input. +-} +choice :: (Monad m, P.Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a +choice = P.choice . map try + +--TODO sepBy &co + + +------ Useful Combinators ------ +{-| Use @many2 a b@ to parse an @a@ followed by zero or more @b@s. -} +many2 :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m [a] +many2 p ps = do + car <- p + cdr <- P.many ps + return (car:cdr) + +{-| Use @between2 a p@ to parse an @a@, then a @p@, then an @a@. Return the + results of the @p@ parser. +-} +between2 :: (Monad m, P.Stream s m t) => ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m b +between2 e p = P.between e e p + +{-| Detect end of file as a boolean. -} +isEof :: (Show t, Monad m, P.Stream s m t) => ParsecT s u m Bool +isEof = (eof >> return True) P.<|> return False + + +{-| One or more spaces. -} +spaces1 :: (Monad m, P.Stream s m Char) => ParsecT s u m () +spaces1 = void $ P.many1 P.space + +{-| Parse one character, case-insensitive. -} +charICase :: (Monad m, P.Stream s m Char) => Char -> ParsecT s u m Char +charICase c = satisfy $ (== toLower c) . toLower + +{-| Parse a string, case-insensitive. If this parser fails, it consumes no input. -} +stringICase :: (Monad m, P.Stream s m Char) => String -> ParsecT s u m String +stringICase str = try $ mapM charICase str + + +------ Parsing Identifiers ------ +{-| Parses a wide variety of characters, excepting those which meet + the passed predicate. Specifically, we accept all of Unicode except: + + * Space + + * LineSeparator + + * ParagraphSeparator + + * Control + + * Format + + * Surrogate + + * PrivateUse + + * NotAssigned +-} +blacklistChar :: (Monad m, P.Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char +blacklistChar p = satisfy $ \c -> not (p c) && case generalCategory c of + Space -> False + LineSeparator -> False + ParagraphSeparator -> False + Control -> False + Format -> False + Surrogate -> False + PrivateUse -> False + NotAssigned -> False + _ -> True --Letter, Mark, Number, Punctuation/Quote, Symbol + +--TODO maybe normal c-like identifiers, maybe identifiers that could be word-based vs. symbol-based + + +------ Parsing Numbers ------ +--TODO common combinations of the number part parsers +{-| Optional sign, then an integer number in scientific notation + or ratio, in base 2, 8, 10 or 16. If in scientific notation, + the exponent may be in base 10 or 16 +-} +anyNumber :: (Monad m, P.Stream s m Char) => ParsecT s u m Rational +anyNumber = ( "number") $ try $ do + sign <- P.option 1 signLiteral + base <- baseLiteral + whole <- naturalLiteral base + n <- choice [ scientificNotation whole base + , fractionNotation whole base + , return (whole % 1) + ] + return $ fromIntegral sign * n + where + scientificNotation whole base = do + mantissa <- mantissaLiteral base + (expbase, exponent) <- P.option (1,0) (decimalExp <|> hexExp) + return $ ((whole % 1) + mantissa) * (fromIntegral expbase ^^ exponent) + fractionNotation whole base = (whole %) . denominator <$> denominatorLiteral base + decimalExp = (,) 10 <$> exponentLiteral 10 + hexExp = (,) 16 <$> exponentLiteral 16 + + +{-| Parse a minus or plus sign and return the appropriate multiplier. -} +signLiteral :: (Monad m, P.Stream s m Char) => ParsecT s u m Integer +signLiteral = ( "sign") $ (char '-' >> return (-1)) P.<|> (char '+' >> return 1) + +{-| Parse \"0x\", \"0o\", or \"0b\" case-insensitive and return the appropriate base. + If none of these parse, return base 10. +-} +baseLiteral :: (Monad m, P.Stream s m Char) => ParsecT s u m Int +baseLiteral = choice [ (stringICase "0x") >> return 16 + , (stringICase "0o") >> return 8 + , (stringICase "0b") >> return 2 + , return 10 + ] + +{-| Parse many digits in the passed base and return the corresponding integer. -} +naturalLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Integer +naturalLiteral base = ( "natural number") $ stringToInteger base <$> P.many1 (xDigit base) + +{-| Parse a dot followed by many digits in the passed base and return + the corresponding ratio. +-} +mantissaLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Rational +mantissaLiteral base = ( "mantissa") $ do + char '.' + stringToMantissa base <$> P.many1 (xDigit base) + +{-| In base 10, parse an 'e' and a decimal integer. + In base 16, parse an 'h' and a hexadecimal integer. +-} +exponentLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Integer +exponentLiteral base = ( "exponent") (go base) + where + body = (*) <$> P.option 1 signLiteral <*> naturalLiteral base + go 10 = charICase 'e' >> body + go 16 = charICase 'h' >> body + go _ = error "unrecognized base in Language.Parser.exponentLiteral (accepts only 10 or 16)" + +{-| Parse a '/' and a natural in the passed base. Return the + reciprocal of that number. +-} +denominatorLiteral :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Rational +denominatorLiteral base = ( "denominator") $ do + denom <- char '/' >> naturalLiteral base + if denom == 0 then parserZero else return (1%denom) + + +{-| Parse a digit in the passed base: 2, 8, 10 or 16. -} +xDigit :: (Monad m, P.Stream s m Char) => Int -> ParsecT s u m Char +xDigit base = case base of + 2 -> oneOf "01" + 8 -> P.octDigit + 10 -> P.digit + 16 -> P.hexDigit + _ -> error "unrecognized base in Language.Parser.xDigit (accepts only 2, 8, 10, or 16)" + +{-| Interpret a string as an integer in the passed base. -} +stringToInteger :: Int -> String -> Integer +stringToInteger base = foldl impl 0 + where impl acc x = acc * fromIntegral base + (fromIntegral . digitToInt) x + +{-| Interpret a string as a mantissa in the passed base. -} +stringToMantissa :: Int -> String -> Ratio Integer +stringToMantissa base = (/ (fromIntegral base%1)) . foldr impl (0 % 1) + where impl x acc = acc / (fromIntegral base%1) + (((%1) . fromIntegral . digitToInt) x) + + +------ Parsing Character Literals ------ +{-| Parse a single character as if in a string literal. This should be applicable + to both character and string literals. + + Here's the list of what characters are accepted: + + * Any single unicode character that is not an ASCII control character, backslash, or double-quote. + + * Line continuation: backslash, then advance over whitespace + (including newlines and comments) through the next backslash. + + * Octal or hexadecimal ASCII escapes: a sequence in @\/\\\\(x[0-9a-fA-F]{2}|o[0-7]{3})\/@. + + * Unicode escapes: a sequence in @\/\\\\(u|U0[0-9a-fA-F]|U10)[0-9a-fA-F]{4}\/@. + + * Special escape: a sequence in @\/\\\\[0abefnrtv\'\"]\/@. + For reference, the meanings of special escapes are: + +@ +\\0: nul (ASCII 0, 0x00) +\\a: bell (ASCII 7, 0x07) +\\b: backspace (ASCII 8, 0x08) +\\e: escape (ASCII 27, 0x1B) +\\f: form feed (ASCII 12, 0x0C) +\\n: line feed (ASCII 10, 0x0A) +\\r: carriage return (ASCII 13, 0x0D) +\\t: horizontal tab (ASCII 9, 0x09) +\\v: vertical tab (ASCII 11, 0x0B) +\\\': single quote (ASCII 39, 0x27) +\\\": double quote (ASCII 34, 0x22) +@ +-} +literalChar :: (Monad m, P.Stream s m Char) => ParsecT s u m Char +literalChar = (satisfy isNormalChar "printing character") P.<|> (escape "escape sequence") + where + isNormalChar c = c >= ' ' && c `notElem` "\DEL\'\"\\" --FIXME limit this slightly more + escape = char '\\' >> P.choice [specialEscape, numericalEscape] + specialEscape = fromJust . flip lookup table <$> oneOf (map fst table) + where table = [ ('0' , '\0') + , ('a' , '\a') + , ('b' , '\b') + , ('e' , '\27') + , ('f' , '\f') + , ('n' , '\n') + , ('r' , '\r') + , ('t' , '\t') + , ('\'', '\'') + , ('\"', '\"') + , ('\\', '\\') + ] + numericalEscape = chr . fromInteger <$> P.choice [ascii16, uni4, ascii8, uni6] + ascii8 = stringToInteger 8 <$> (oneOf "oO" >> P.count 3 P.octDigit) + ascii16 = stringToInteger 16 <$> (oneOf "xX" >> P.count 2 P.hexDigit) + uni4 = stringToInteger 16 <$> (char 'u' >> P.count 4 P.hexDigit) + uni6 = char 'U' >> (high P.<|> low) + where + low = stringToInteger 16 <$> (char '0' >> P.count 5 P.hexDigit) + high = (+ 0x100000) . stringToInteger 16 <$> (string "10" >> P.count 4 P.hexDigit) + +{-| Parse any character accepted by 'literalChar', but also accept two empty characters: + + * @\\&@ The eplicit empty character. + + * Backslash-whitespace-backslash. +-} +maybeLiteralChar :: (Monad m, P.Stream s m Char) => ParsecT s u m (Maybe Char) +maybeLiteralChar = (Just <$> literalChar) P.<|> (const Nothing <$> (string "\\&" P.<|> lineContinue)) + where + lineContinue = between2 (char '\\') (P.many $ oneOf " \t\n\r") --FIXME more types of whitespace could be allowed + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hexpr.cabal b/hexpr.cabal new file mode 100644 --- /dev/null +++ b/hexpr.cabal @@ -0,0 +1,75 @@ +-- Initial spine.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: hexpr + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.0.0.0 + + +synopsis: A framework for symbolic, homoiconic languages. + +description: H-expressions are a variant of S-expressions. Where s-expressions are atoms or nodes grouped into lists of length at least one, h-expressions, or hexprs, are grouped into lists of length two. This may seem very trivial, but this restriction makes it possible to treat parenthesis in the concrete syntax of hexprs merely as a manual override to the basic precedence rules, just as in mathematics. In particular, a suitable hexpr interpreter is capable of understanding eta-converted terms, which is quite unrealistic, if not impossible in an sexpr-based syntax. Thankfully, hexprs retain all the advantages of sexprs with respect to homoiconic syntax. + + Hexprs on their own are fairly unhelpful, so we also have also included a configurable hexpr parser based on parsec. I wasn't long before mission creep set in, and a series of tools were produced to aid in creating a frontend for hexpr-based languages. See the package 'hexpr-examples' for some examples of the framework in action. + + I think H could stand for many things: the greek letter eta, hierarchical, happy, next in the alphabet after f, or perhaps hexpr == hexpr-expression. Where it comes from is unimportant, what is important is that we can easily the next generation of homoiconic languages. + +-- URL for the project homepage or repository. +homepage: https://github.com/Zankoku-Okuno/hexpr/ + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Zankoku Okuno + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: zankoku.okuno@gmail.com + +-- A copyright notice. +-- copyright: + +category: Language + +build-type: Simple + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.8 + + +library + -- Modules exported by the library. + exposed-modules: Data.Hierarchy, + Data.Sexpr, + Data.Hexpr, + Language.Parse, + Language.Desugar, + Language.Distfix, + Control.Monad.Stack, + Control.Monad.Errors, + Control.Monad.Gensym, + Control.Monad.Environment, + Data.FiniteType + + -- Modules included in this library but not exported. + -- other-modules: + + -- Other library packages from which modules are imported. + build-depends: base ==4.6.*, + transformers ==0.3.*, + mtl ==2.1.*, + either ==4.1.*, + parsec ==3.1.*, + data-ref +