• example
  • data structures for
    • symbol tree
      • with Terminal Chars as leafs
    • container Construction as monadic class and instances
      • error handling
    • newtypes for standard Construction instances
      • String'
      • in order to have standard build of constructions
    • easy combination methods for childs of symbol trees
  • code:<cose Haskell>

{-# LANGUAGE FlexibleInstances #-}

import qualified Control.Monad as M (liftM, ap) import qualified Data.Foldable as Fld (foldlM, foldrM)

main :: IO () main =

  do
      print (buildValidM symTheTree :: (Construction Integer))

symTheTree :: SymbolTree symTheTree =

  Node Div [                          -- shall create an Integer
      Node Mul [                        -- shall create an Integer
          Node Add [                      -- shall create an Integer
              Node Number [                 -- shall create an Integer (and/or String)
                  Node (Terminal '3') [],     -- shall create a Char
                  Node (Terminal '3') [],     -- shall create a Char
                  Node (Terminal '3') [],     -- shall create a Char
                  Node (Terminal '1') []],    -- shall create a Char
              Node Number [                 -- shall create an Integer (and/or String)
                  Node (Terminal '3') [],     -- shall create a Char
                  Node (Terminal '3') [],     -- shall create a Char
                  Node (Terminal '1') []]],   -- shall create a Char
          Node Sub [                      -- shall create an Integer
              Node Number [                 -- shall create an Integer (and/or String)
                  Node (Terminal '3') [],   -- shall create a Char
                  Node (Terminal '3') [],   -- shall create a Char
                  Node (Terminal '1') []],  -- shall create a Char
              Node Number [               -- shall create an Integer (and/or String)
                  Node (Terminal '1') [],   -- shall create a Char
                  Node (Terminal '3') []]]],-- shall create a Char
      Node Number [                       -- shall create an Integer (and/or String)
          Node (Terminal '7') []]]          -- shall create a Char

data SymbolTree = Node Symbol [SymbolTree]

  deriving Show

data Symbol = Add | Sub | Mul | Div | Number | Terminal Char

  deriving Show

data Construction model = Contains model | Error ErrorKind

  deriving Show

data ErrorKind =

    ErrSymTree { rsInstance :: String, rsPattern :: String }
  | Constraint { rsCase :: String, rsConstraint :: String }
  deriving Show

newtype String' = String' String

  deriving Show

instance Functor Construction where

  fmap = M.liftM

instance Applicative Construction where

  pure = return
  (<*>) = M.ap

instance Monad Construction where

  (Contains x) >>= g  = g x
  Error s       >>= _ = Error s
  return              = Contains

class Gen g where

  buildValidM :: SymbolTree -> (Construction g)
  buildValidDflt :: g
  buildValid :: SymbolTree -> g
  buildValid symTree = 
      let buildValid' (Error _) = buildValidDflt
          buildValid' (Contains x) = x
      in buildValid' (buildValidM symTree)
  constraint :: (g -> Bool) -> String -> String -> (Construction g) -> (Construction g)
  constraint _ _ _ g@(Error _) = g
  constraint fConstraint sCase sConstraint (Contains g) 
      | fConstraint g = (Contains g)
      | otherwise = Error (Constraint sCase sConstraint)

fOpFromSymTree :: (Gen g) ⇒ (g → g → g) → (SymbolTree → g → Construction g) fOpFromSymTree fOp trSymA nB =

  do
      nA <- buildValidM trSymA
      return (fOp nA nB);

fOpFlippedFromSymTree :: (Gen g) ⇒ (g → g → g) → (g → SymbolTree → Construction g) fOpFlippedFromSymTree fOp nA trSymB =

  do
      nB <- buildValidM trSymB
      return (fOp nA nB);

cmbnNCmt :: (Gen g) ⇒ (g → g → g) → g → [SymbolTree] → Construction g cmbnNCmt fOp identity ltrSym = Fld.foldrM (fOpFromSymTree fOp) identity ltrSym

cmbnFast :: (Gen g) ⇒ (g → g → g) → g → [SymbolTree] → Construction g cmbnFast fOp identity ltrSym = Fld.foldlM (fOpFlippedFromSymTree fOp) identity ltrSym

instance Gen String' where

  buildValidDflt = (String' "")
  buildValidM (Node (Terminal ch) _) = Contains (String' [ch])
  buildValidM (Node _ ltrSym) = (cmbnFast (s'concat) (String' "") ltrSym)

s'concat :: String' → String' → String' s'concat (String' sA) (String' sB) = String' (sA ++ sB)

instance Gen Integer where

  buildValidDflt = 0
  buildValidM symTree@(Node Number _) = (Contains (read (buildValid symTree)))
  buildValidM (Node Add ltrSym) = cnstInt "Add" $ cmbnFast (+) 0 ltrSym
  buildValidM (Node Sub ltrSym) = cnstInt "Sub" $ cmbnNCmt (-) 0 ltrSym
  buildValidM (Node Mul ltrSym) = cnstInt "Mul" $ cmbnFast (*) 1 ltrSym
  buildValidM (Node Div ltrSym) = cnstInt "Div" $ cmbnNCmt (div) 1 ltrSym
  buildValidM _ = Error (ErrSymTree "instance Gen Integer" "buildValidM _")

cnstInt :: String → (Construction Integer) → (Construction Integer) cnstInt sCase g = constraint (⇐ 65535) sCase “smaller than 2^16-1” g

instance Gen String where

  buildValidDflt = ""
  buildValidM (Node Number ltrSym) = Contains [ch | (Contains ch) <- (map buildValidM ltrSym) ]
  --buildValidM (Node _ ltrSym) = cmbnFast (++) "" ltrSym
  buildValidM _ = Error (ErrSymTree "instance Gen String" "buildValidM _")

instance Gen Char where

  buildValidDflt = ' '
  buildValidM (Node (Terminal ch) _) = Contains ch
  buildValidM _ = Error (ErrSymTree "instance Gen Char" "buildValidM _")

</code>