This is an old revision of the document!

Creating data structures from symbol trees

example

data structures for
- symbol tree
  - with Terminal Chars as leafs
- container Construction as monadic class and instances
  - error handling
- types for standard Construction instances
  - String'
  - in order to have standard build of constructions
- easy combination methods for childs of symbol trees
  - cmbnFast
    - for faster execution, using foldlM
  - cmbnNCmt
    - for compatibility to non commutative operations like subtraction and devision, using foldrM
- using GHC Extension FlexibleInstances
- using GHC option -fno-warn-orphans

code, module Main:

{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
 
module Main where
 
import Builder (Builder(..), SymbolTree(..), Symbol(..), Construction(..), ErrorKind(..), String', cmbnFast, cmbnNCmt)
 
main :: IO ()
main = 
    do
        print (buildValidM symTheTree :: (Construction String'))
 
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
 
instance Builder 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 Builder Integer" "buildValidM _")
 
cnstInt :: String -> (Construction Integer) -> (Construction Integer)
cnstInt sCase g = constraint (<= 4294967295) sCase "smaller than 2^32-1" g
 
instance Builder String where
    buildValidDflt = ""
    buildValidM (Node Number ltrSym) = Contains [ch | (Contains ch) <- (map buildValidM ltrSym) ]
    buildValidM _ = Error (ErrSymTree "instance Builder String" "buildValidM _")
 
instance Builder Char where
    buildValidDflt = ' '
    buildValidM (Node (Terminal ch) _) = Contains ch
    buildValidM _ = Error (ErrSymTree "instance Builder Char" "buildValidM _")

code, module Builder:

{-|
Description : to create data structures from symbol trees.
Copyright   : (c) Jörg K.-H. W. Brüggmann, 2021
License     : CC0 1.0 Universal
Maintainer  : - none -
Stability   : experimental
Portability : POSIX
 
* supports creation of any data structures from symbol trees which type is defined in here:
 
* example
 
    @
    instance Builder 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 Builder Integer" "buildValidM _")
 
    cnstInt :: String -> (Construction Integer) -> (Construction Integer)
    cnstInt sCase g = constraint (<= 4294967295) sCase "smaller than 2^32-1" g
 
    instance Builder String where
        buildValidDflt = ""
        buildValidM (Node Number ltrSym) = Contains [ch | (Contains ch) <- (map buildValidM ltrSym) ]
        buildValidM _ = Error (ErrSymTree "instance Builder String" "buildValidM _")
 
    instance Builder Char where
        buildValidDflt = ' '
        buildValidM (Node (Terminal ch) _) = Contains ch
        buildValidM _ = Error (ErrSymTree "instance Builder Char" "buildValidM _")
    @
-}
 
{-# LANGUAGE FlexibleInstances #-}
 
module Builder (
    -- * Classes
    Builder(..), 
    -- * Types
    SymbolTree(..), 
    Symbol(..), 
    Construction(..), 
    ErrorKind(..), 
    String', 
    -- * Functions
    fOpFromSymTree, 
    fOpFlippedFromSymTree, 
    cmbnNCmt, 
    cmbnFast
    ) where
 
import qualified Control.Monad as M (liftM, ap)
import qualified Data.Foldable as Fld (foldlM, foldrM)
 
--------------------------------------------------------------------------------
--  Basic types
 
data Symbol = Add | Sub | Mul | Div | Number | Terminal Char
    deriving Show
 
data SymbolTree = Node Symbol [SymbolTree]
    deriving Show
 
data ErrorKind = 
      ErrSymTree { rsInstance :: String, rsPattern :: String }
    | Constraint { rsCase :: String, rsConstraint :: String }
    deriving Show
 
--------------------------------------------------------------------------------
--  Monadic type
 
data Construction model = Contains model | Error ErrorKind
    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
 
--------------------------------------------------------------------------------
--  Type class 'Builder'
 
class Builder 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)
 
--------------------------------------------------------------------------------
--  'Builder' instance String'
 
type String' = SimpleContainer String
 
newtype SimpleContainer a = Simply a
    deriving Show
 
instance Builder (SimpleContainer String) where
    buildValidDflt = (Simply "")
    buildValidM (Node (Terminal ch) _) = Contains (Simply [ch])
    buildValidM (Node _ ltrSym) = (cmbnFast (liftSimply (++)) (Simply "") ltrSym)
 
liftSimply :: (a -> a -> a) -> (SimpleContainer a) -> (SimpleContainer a) -> (SimpleContainer a)
liftSimply f (Simply xA) (Simply xB) = Simply (f xA xB)
 
--------------------------------------------------------------------------------
--  Helper functions for type class 'Builder'
 
fOpFromSymTree :: (Builder g) => (g -> g -> g) -> (SymbolTree -> g -> Construction g)
fOpFromSymTree fOp trSymA nB = 
    do
        nA <- buildValidM trSymA
        return (fOp nA nB);
 
fOpFlippedFromSymTree :: (Builder g) => (g -> g -> g) -> (g -> SymbolTree -> Construction g)
fOpFlippedFromSymTree fOp nA trSymB = 
    do
        nB <- buildValidM trSymB
        return (fOp nB nA);
 
cmbnNCmt :: (Builder g) => (g -> g -> g) -> g -> [SymbolTree] -> Construction g
cmbnNCmt fOp identity ltrSym = Fld.foldrM (fOpFromSymTree fOp) identity ltrSym
 
cmbnFast :: (Builder g) => (g -> g -> g) -> g -> [SymbolTree] -> Construction g
cmbnFast fOp identity ltrSym = Fld.foldlM (fOpFlippedFromSymTree fOp) identity ltrSym

You could leave a comment if you were logged in.