Sequence.hs

{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- Copyright 2018, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- A type class for sequences together with the 'Firsts' type class for
-- accessing the firsts set and ready predicate.
--
-----------------------------------------------------------------------------

module Ideas.Common.Strategy.Sequence
   ( -- * Sequence type class
     Sequence(..)
     -- * Firsts type class
   , Firsts(..), firstsTree
   ) where

import Ideas.Common.DerivationTree

infixr 5 .*., ~>

------------------------------------------------------------------------
-- Sequence type class

class Sequence a where
   type Sym a
   -- | The empty sequence.
   done :: a
   -- | Prepend a symbol to a sequence.
   (~>) :: Sym a -> a -> a
   -- | Append two sequences.
   (.*.) :: a -> a -> a
   -- | Singleton sequence.
   single :: Sym a -> a
   single s = s ~> done
   -- | Sequential composition.
   sequence :: [a] -> a
   sequence xs = if null xs then done else foldr1 (.*.) xs

instance Sequence b => Sequence (a -> b) where
   type Sym (a -> b) = Sym b

   done   = const done
   single = const . single
   a ~> f = (a ~>) . f
   (f .*. g) x = f x .*. g x

------------------------------------------------------------------------
-- Firsts type class

class Firsts s where
   -- | The type associated with a step in the first set.
   type Elem s
   -- | The ready predicate (we are done).
   ready :: s -> Bool
   -- | The firsts set.
   firsts :: s -> [(Elem s, s)]

firstsTree :: Firsts s => s -> DerivationTree (Elem s) s
firstsTree x = addBranches bs tr
 where
   tr = singleNode x (ready x)
   bs = [ (a, firstsTree y) | (a, y) <- firsts x ]