<commit_before>{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
-- under the terms of the GNU General Public License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  <EMAIL>
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- This module defines views on data-types, as described in "Canonical Forms
-- in Interactive Exercise Assistants"
--
-----------------------------------------------------------------------------
module Common.View 
   ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
   , (>>>), (<<<)
     -- *  @IsView@ type class
   , IsView(..), matchM
   , canonical, canonicalWith, canonicalWithM, isCanonical, isCanonicalWith
   , simplify, simplifyWith
   , belongsTo, viewEquivalent, viewEquivalentWith
     -- * Views
   , View, identity, makeView
     -- * Isomorphisms
   , Isomorphism, from, to
     -- * Some combinators
   , swapView, listView, traverseView, ($<)
     -- * Packaging a view
   , ViewPackage(..)
     -- * Properties on views
   , propIdempotence, propSoundness, propNormalForm
   ) where

import Common.Id
import Control.Arrow
import Common.Classes
import Control.Monad
import Data.Maybe
import Test.QuickCheck
import qualified Control.Category as C
import qualified Data.Traversable as T

----------------------------------------------------------------------------------
-- @IsView@ type class 

-- |Minimal complete definition: @toView@ or both @match@ and @build@.
class IsView f where
   match  :: f a b -> a -> Maybe b
   build  :: f a b -> b -> a
   toView :: f a b -> View a b
   -- default definitions
   match  f = match (toView f)
   build  f = build (toView f)
   toView f = makeView (match f) (build f)

-- |generalized monadic variant of @match@
matchM :: (Monad m, IsView f) => f a b -> a -> m b
matchM v = maybe (fail "no match") return . match v

canonical :: IsView f => f a b -> a -> Maybe a
canonical = canonicalWith id

canonicalWith :: IsView f => (b -> b) -> f a b -> a -> Maybe a
canonicalWith f = canonicalWithM (return . f)

canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
canonicalWithM f view a = 
   match view a >>= liftM (build view) . f

isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
isCanonical = isCanonicalWith (==)
      
isCanonicalWith :: IsView f => (a -> a -> Bool) -> f a b -> a -> Bool
isCanonicalWith eq v a = maybe False (eq a) (canonical v a)

simplify :: IsView f => f a b -> a -> a
simplify = simplifyWith id

simplifyWith :: IsView f => (b -> b) -> f a b -> a -> a
simplifyWith f view a = fromMaybe a (canonicalWith f view a)

belongsTo :: IsView f => a -> f a b -> Bool
belongsTo a view = isJust (match view a)

viewEquivalent :: (IsView f, Eq b) => f a b -> a -> a -> Bool
viewEquivalent = viewEquivalentWith (==)

viewEquivalentWith :: IsView f => (b -> b -> Bool) -> f a b -> a -> a -> Bool
viewEquivalentWith eq view x y =
   case (match view x, match view y) of
      (Just a, Just b) -> a `eq` b
      _                -> False

----------------------------------------------------------------------------------
-- Views

data View a b where
   Prim    :: (a -> Maybe b) -> (b -> a) -> View a b
   (:@)    :: Id -> View a b -> View a b
   (:>>>:) :: View a b -> View b c -> View a c 
   (:***:) :: View a c -> View b d -> View (a, b) (c, d)
   (:+++:) :: View a c -> View b d -> View (Either a b) (Either c d)
   Traverse :: T.Traversable f => View a b -> View (f a) (f b)

instance C.Category View where
   id    = makeView return id
   v . w = w :>>>: v

instance Arrow View where
   arr     = (!->)
   first   = (*** identity) 
   second  = (identity ***)
   (***)   = (:***:)
   f &&& g = copy >>> (f *** g)

instance BiArrow View where
   (<->) f = makeView (return . f)

instance ArrowChoice View where
   left    = (+++ identity)
   right   = (identity +++)
   (+++)   = (:+++:)
   f ||| g = (f +++ g) >>> merge

instance IsView View where
   match view =
      case view of
         Prim f _   -> f
         _ :@ v     -> match v
         v :>>>: w  -> \a      -> match v a >>= match w
         v :***: w  -> \(a, c) -> liftM2 (,) (match v a) (match w c)
         v :+++: w  -> either (liftM Left . match v) (liftM Right . match w)
         Traverse v -> T.mapM (match v)

   build view = 
      case view of
         Prim _ f   -> f
         _ :@ v     -> build v
         v :>>>: w  -> build v . build w
         v :***: w  -> build v *** build w
         v :+++: w  -> either (Left . build v) (Right . build w)
         Traverse v -> fmap (build v)

   toView = id

instance HasId (View a b) where
   getId (n :@ _) = n
   getId _        = mempty
   changeId f (n :@ a) = f n :@ a
   changeId f a        = f mempty :@ a

instance Identify (View a b) where
   n @> v | isEmptyId a = v
          | otherwise   = a :@ v
    where
      a = newId n

makeView :: (a -> Maybe b) -> (b -> a) -> View a b
makeView = Prim

identity :: C.Category f => f a a 
identity = C.id

----------------------------------------------------------------------------------
-- Isomorphisms (embedding-projection pairs)

-- to ep . from ep == id
data Isomorphism a b = EP { pid :: Id, from :: a -> b, to :: b -> a }

instance C.Category Isomorphism where
   id    = id <-> id
   f . g = from f . from g <-> to g . to f

instance Arrow Isomorphism where
   arr     = (!->)
   first   = (*** identity) 
   second  = (identity ***)
   p *** q = from p *** from q <-> to p *** to q
   f &&& g = copy >>> (f *** g)

instance BiArrow Isomorphism where
   (<->) = EP mempty

instance ArrowChoice Isomorphism where
   left    = (+++ identity)
   right   = (identity +++)
   p +++ q = from p +++ from q <-> to p +++ to q
   f ||| g = (f +++ g) >>> merge

instance IsView Isomorphism where
   toView p = getId p @> makeView (Just . from p) (to p)<commit_msg>extending View interface with Match data type<commit_after>{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- Copyright 2010, Open Universiteit Nederland. This file is distributed 
-- under the terms of the GNU General Public License. For more information, 
-- see the file "LICENSE.txt", which is included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  <EMAIL>
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- This module defines views on data-types, as described in "Canonical Forms
-- in Interactive Exercise Assistants"
--
-----------------------------------------------------------------------------
module Common.View 
   ( Control.Arrow.Arrow(..), Control.Arrow.ArrowChoice(..)
   , Control.Arrow.ArrowZero(..), Control.Arrow.ArrowPlus(..)
   , (>>>), (<<<)
     -- * @IsMatch@ type class
   , IsMatch(..), matchM, belongsTo, viewEquivalent, viewEquivalentWith
   , Match, makeMatch
     -- * @IsView@ type class
   , IsView(..), simplify, simplifyWith
   , canonical, canonicalWith, canonicalWithM, isCanonical, isCanonicalWith
     -- * Views
   , View, identity, makeView, matcherView
     -- * Isomorphisms
   , Isomorphism, from, to
     -- * Some combinators
   , swapView, listView, traverseView, ($<)
     -- * Packaging a view
   , ViewPackage(..)
     -- * Properties on views
   , propIdempotence, propSoundness, propNormalForm
   ) where

import Common.Id
import Control.Arrow
import Common.Classes
import Control.Monad
import Data.Maybe
import Test.QuickCheck
import qualified Control.Category as C
import qualified Data.Traversable as T

----------------------------------------------------------------------------------
-- @IsMatch@ type class 

class IsMatch f where
   match   :: f a b -> a -> Maybe b
   matcher :: f a b -> Match a b
   -- default definitions
   match   = runKleisli . unM . matcher
   matcher = makeMatch . match

-- |generalized monadic variant of @match@
matchM :: (Monad m, IsMatch f) => f a b -> a -> m b
matchM v = maybe (fail "no match") return . match v

belongsTo :: IsMatch f => a -> f a b -> Bool
belongsTo a view = isJust (match view a)

viewEquivalent :: (IsMatch f, Eq b) => f a b -> a -> a -> Bool
viewEquivalent = viewEquivalentWith (==)

viewEquivalentWith :: IsMatch f => (b -> b -> Bool) -> f a b -> a -> a -> Bool
viewEquivalentWith eq view x y =
   case (match view x, match view y) of
      (Just a, Just b) -> a `eq` b
      _                -> False

newtype Match a b = M { unM :: Kleisli Maybe a b }
   deriving (C.Category, Arrow, ArrowZero, ArrowPlus, ArrowChoice)

instance IsMatch Match where
   matcher = id

makeMatch :: (a -> Maybe b) -> Match a b
makeMatch = M . Kleisli

----------------------------------------------------------------------------------
-- @IsView@ type class 

-- |Minimal complete definition: @toView@ or both @match@ and @build@.
class IsMatch f => IsView f where
   build  :: f a b -> b -> a
   toView :: f a b -> View a b
   -- default definitions
   build  f = build (toView f)
   toView f = makeView (match f) (build f)

canonical :: IsView f => f a b -> a -> Maybe a
canonical = canonicalWith id

canonicalWith :: IsView f => (b -> b) -> f a b -> a -> Maybe a
canonicalWith f = canonicalWithM (return . f)

canonicalWithM :: IsView f => (b -> Maybe b) -> f a b -> a -> Maybe a
canonicalWithM f view a = 
   match view a >>= liftM (build view) . f

isCanonical :: (IsView f, Eq a) => f a b -> a -> Bool
isCanonical = isCanonicalWith (==)
      
isCanonicalWith :: IsView f => (a -> a -> Bool) -> f a b -> a -> Bool
isCanonicalWith eq v a = maybe False (eq a) (canonical v a)

simplify :: IsView f => f a b -> a -> a
simplify = simplifyWith id

simplifyWith :: IsView f => (b -> b) -> f a b -> a -> a
simplifyWith f view a = fromMaybe a (canonicalWith f view a)

----------------------------------------------------------------------------------
-- Views

data View a b where
   Prim    :: Match a b -> (b -> a) -> View a b
   (:@)    :: Id -> View a b -> View a b
   (:>>>:) :: View a b -> View b c -> View a c 
   (:***:) :: View a c -> View b d -> View (a, b) (c, d)
   (:+++:) :: View a c -> View b d -> View (Either a b) (Either c d)
   Traverse :: T.Traversable f => View a b -> View (f a) (f b)

instance C.Category View where
   id    = makeView return id
   v . w = w :>>>: v

instance Arrow View where
   arr     = (!->)
   first   = (*** identity) 
   second  = (identity ***)
   (***)   = (:***:)
   f &&& g = copy >>> (f *** g)

instance BiArrow View where
   (<->) f = makeView (return . f)

instance ArrowChoice View where
   left    = (+++ identity)
   right   = (identity +++)
   (+++)   = (:+++:)
   f ||| g = (f +++ g) >>> merge

instance IsMatch View where 
   matcher view =
      case view of
         Prim m _   -> m
         _ :@ v     -> matcher v
         v :>>>: w  -> matcher v >>> matcher w
         v :***: w  -> matcher v *** matcher w
         v :+++: w  -> matcher v +++ matcher w
         Traverse v -> makeMatch $ T.mapM (match v)

instance IsView View where
   build view = 
      case view of
         Prim _ f   -> f
         _ :@ v     -> build v
         v :>>>: w  -> build v <<< build w
         v :***: w  -> build v *** build w
         v :+++: w  -> either (Left . build v) (Right . build w)
         Traverse v -> fmap (build v)

   toView = id

instance HasId (View a b) where
   getId (n :@ _) = n
   getId _        = mempty
   changeId f (n :@ a) = f n :@ a
   changeId f a        = f mempty :@ a

instance Identify (View a b) where
   n @> v | isEmptyId a = v
          | otherwise   = a :@ v
    where
      a = newId n

makeView :: (a -> Maybe b) -> (b -> a) -> View a b
makeView = matcherView . makeMatch

matcherView :: Match a b -> (b -> a) -> View a b
matcherView = Prim

identity :: C.Category f => f a a 
identity = C.id

----------------------------------------------------------------------------------
-- Isomorphisms (embedding-projection pairs)

-- to ep . from ep == id
data Isomorphism a b = EP { pid :: Id, from :: a -> b, to :: b -> a }

instance C.Category Isomorphism where
   id    = id <-> id
   f . g = from f . from g <-> to g . to f

instance Arrow Isomorphism where
   arr     = (!->)
   first   = (*** identity) 
   second  = (identity ***)
   p *** q = from p *** from q <-> to p *** to q
   f &&& g = copy >>> (f *** g)

instance BiArrow Isomorphism where
   (<->) = EP mempty

instance ArrowChoice Isomorphism where
   left    = (+++ identity)
   right   = (identity +++)
   p +++ q = from p +++ from q <-> to p +++ to q
   f ||| g = (f +++ g) >>> merge

instance IsMatch Isomorphism where
   match p = Just . from p

instance IsView Isomorphism where
   toView p = getId p @> makeView (match p) (to p)
{'fraction_non_alphanumeric': 0.21625173960105148, 'fraction_numerical': 0.0006958404205968764, 'mean_word_length': 1.7404661016949152, 'pattern_counts': {'":': 0, '<': 28, '<?xml version=': 0, '>': 270, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '763894', 'n_tokens_mistral': 4128, 'n_tokens_neox': 4024, 'n_words': 1576}