symantic-document/Language/Symantic/Document/Valid.hs

   1 module Language.Symantic.Document.Valid where
   2
   3 import Control.Applicative (Applicative(..))
   4 import Control.Monad (Monad(..))
   5 import Data.Eq (Eq(..))
   6 import Data.Foldable (any)
   7 import Data.Function (($), (.), id)
   8 import Data.Functor (Functor(..))
   9 import Data.Int (Int)
  10 import Data.Monoid (Monoid(..))
  11 import Data.Ord (Ord(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (IsString(..))
  14 import Text.Show (Show)
  15 import qualified Data.Text as T
  16 import qualified Data.Text.Lazy as TL
  17
  18 import Language.Symantic.Document.Sym
  19
  20 -- * Type 'Valid'
  21 data Valid repr
  22  =   KO [Error_Valid]
  23  |   Ok repr
  24  deriving (Eq, Show)
  25 instance IsString repr => IsString (Valid repr) where
  26         fromString = Ok . fromString
  27
  28 valid :: Valid repr -> Valid repr
  29 valid = id
  30
  31 -- ** Type 'Error_Valid'
  32 data Error_Valid
  33  =   Error_Valid_not_horizontal TL.Text
  34  |   Error_Valid_negative_spaces Int
  35  deriving (Eq, Show)
  36
  37 instance Semigroup repr => Semigroup (Valid repr) where
  38         Ok x <> Ok y = Ok $ x <> y
  39         KO x <> Ok _ = KO x
  40         Ok _ <> KO y = KO y
  41         KO x <> KO y = KO $ x <> y
  42 instance (Doc_Text repr, Semigroup repr) => Monoid (Valid repr) where
  43         mempty  = empty
  44         mappend = (<>)
  45 instance Functor Valid where
  46         fmap _ (KO e) = KO e
  47         fmap f (Ok a) = Ok $ f a
  48 instance Applicative Valid where
  49         pure = Ok
  50         Ok f  <*> Ok a  = Ok $ f a
  51         KO e  <*> KO e' = KO $ e <> e'
  52         Ok _f <*> KO e  = KO e
  53         KO e  <*> Ok _a = KO e
  54 instance Monad Valid where
  55         return = Ok
  56         Ok a >>= f = f a
  57         KO e >>= _ = KO e
  58 instance (Doc_Text repr, Semigroup repr) => Doc_Text (Valid repr) where
  59         spaces i | i < 0 = KO [Error_Valid_negative_spaces i]
  60         spaces i   = Ok $ spaces i
  61         int        = pure . int
  62         integer    = pure . integer
  63         char       = pure . char
  64         string     = pure . string
  65         text       = pure . text
  66         ltext      = pure . ltext
  67         charH '\n' = KO [Error_Valid_not_horizontal $ TL.singleton '\n']
  68         charH c    = Ok $ charH c
  69         stringH t  | any (== '\n') t = KO [Error_Valid_not_horizontal $ fromString t]
  70         stringH t  = Ok $ stringH t
  71         textH   t  | T.any (== '\n') t = KO [Error_Valid_not_horizontal $ TL.fromStrict t]
  72         textH   t  = Ok $ textH t
  73         ltextH  t  | TL.any (== '\n') t = KO [Error_Valid_not_horizontal t]
  74         ltextH  t  = Ok $ ltextH t
  75 instance Doc_Color repr => Doc_Color (Valid repr) where
  76         reverse     = fmap reverse
  77         black       = fmap black
  78         red         = fmap red
  79         green       = fmap green
  80         yellow      = fmap yellow
  81         blue        = fmap blue
  82         magenta     = fmap magenta
  83         cyan        = fmap cyan
  84         white       = fmap white
  85         blacker     = fmap blacker
  86         redder      = fmap redder
  87         greener     = fmap greener
  88         yellower    = fmap yellower
  89         bluer       = fmap bluer
  90         magentaer   = fmap magentaer
  91         cyaner      = fmap cyaner
  92         whiter      = fmap whiter
  93         onBlack     = fmap onBlack
  94         onRed       = fmap onRed
  95         onGreen     = fmap onGreen
  96         onYellow    = fmap onYellow
  97         onBlue      = fmap onBlue
  98         onMagenta   = fmap onMagenta
  99         onCyan      = fmap onCyan
 100         onWhite     = fmap onWhite
 101         onBlacker   = fmap onBlacker
 102         onRedder    = fmap onRedder
 103         onGreener   = fmap onGreener
 104         onYellower  = fmap onYellower
 105         onBluer     = fmap onBluer
 106         onMagentaer = fmap onMagentaer
 107         onCyaner    = fmap onCyaner
 108         onWhiter    = fmap onWhiter
 109 instance Doc_Decoration repr => Doc_Decoration (Valid repr) where
 110         bold      = fmap bold
 111         italic    = fmap italic
 112         underline = fmap underline