never executed always true always false

    1 {-# LANGUAGE AllowAmbiguousTypes #-}
    2 {-# LANGUAGE DuplicateRecordFields #-}
    3 {-# LANGUAGE GADTs #-}
    4 
    5 {- |
    6 Module      : NITTA.Intermediate.Functions
    7 Description : Accum function
    8 Copyright   : (c) Daniil Prohorov, 2019
    9 License     : BSD3
   10 Maintainer  : aleksandr.penskoi@gmail.com
   11 Stability   : experimental
   12 -}
   13 module NITTA.Intermediate.Functions.Accum (
   14     Acc (..),
   15     Action (..),
   16     Sign (..),
   17 
   18     -- * Acc to function
   19     acc,
   20     accFromStr,
   21 
   22     -- * Utils functions
   23     isPull,
   24     isPush,
   25 ) where
   26 
   27 import Data.List (nub, partition)
   28 import Data.List.Split (splitWhen)
   29 import Data.Set qualified as S
   30 import Data.String.ToString
   31 import Data.String.Utils qualified as S
   32 import Data.Text qualified as T
   33 import Data.Typeable
   34 import NITTA.Intermediate.Types
   35 import NITTA.Utils.Base
   36 import Text.Regex
   37 
   38 data Sign = Plus | Minus deriving (Typeable, Eq)
   39 
   40 instance Show Sign where
   41     show Plus = "+"
   42     show Minus = "-"
   43 
   44 data Action v = Push Sign (I v) | Pull (O v) deriving (Typeable, Eq)
   45 
   46 instance Var v => Show (Action v) where
   47     show (Push s (I v)) = show s <> toString v
   48     show (Pull (O vs)) = S.join " " $ map ("= " <>) $ vsToStringList vs
   49 
   50 instance Variables (Action v) v where
   51     variables (Push _s i) = variables i
   52     variables (Pull o) = variables o
   53 
   54 newtype Acc v x = Acc {actions :: [Action v]} deriving (Typeable, Eq)
   55 
   56 instance Var v => Show (Acc v x) where
   57     show (Acc acts) =
   58         let lastElement = last acts
   59             initElements = init acts
   60             showElement inp@(Push _ _) = show inp
   61             showElement out@(Pull _) = show out <> ","
   62             elements = S.join " " $ map showElement initElements <> [show lastElement]
   63          in "Acc(" <> elements <> ")"
   64 
   65 instance Label (Acc v x) where label Acc{} = "Acc"
   66 
   67 -- | Create function with type F of Acc
   68 acc lst = packF $ Acc lst
   69 
   70 -- | Special function for generating Acc from string, examples in tests
   71 accFromStr desc = packF $ accGen $ toBlocksSplit desc
   72 
   73 isPull Pull{} = True
   74 isPull _ = False
   75 
   76 isPush Push{} = True
   77 isPush _ = False
   78 
   79 fromPush (Push _ (I v)) = v
   80 fromPush _ = error "Error in fromPush function in acc"
   81 
   82 fromPull (Pull (O vs)) = vs
   83 fromPull _ = error "Error in fromPull function in acc"
   84 
   85 instance Ord v => Function (Acc v x) v where
   86     inputs (Acc lst) = S.fromList $ map fromPush $ filter isPush lst
   87     outputs (Acc lst) = unionsMap fromPull $ filter isPull lst
   88 
   89 instance Ord v => Patch (Acc v x) (v, v) where
   90     patch diff (Acc lst) =
   91         Acc $
   92             nub $
   93                 map
   94                     ( \case
   95                         Push s v -> Push s (patch diff v)
   96                         Pull vs -> Pull (patch diff vs)
   97                     )
   98                     lst
   99 
  100 exprPattern = mkRegex "[+,=,-]*[a-zA-Z0-9]+|;"
  101 toBlocksSplit exprInput =
  102     let splitBySemicolon = filter (not . null) . splitWhen (== ";")
  103         matchAll p inpS res =
  104             case matchRegexAll p inpS of
  105                 Just (_, x, xs, _) -> x : matchAll p xs res
  106                 Nothing -> []
  107         filtered = subRegex (mkRegex "[ ]+") exprInput ""
  108      in splitBySemicolon $ matchAll exprPattern filtered []
  109 
  110 accGen blocks =
  111     let partedExpr =
  112             map
  113                 ( partition $ \case
  114                     (x : _) -> x /= '='
  115                     x -> error $ "error in accGen: " <> show x
  116                 )
  117         signPush ('+' : name) = Push Plus (I $ T.pack name)
  118         signPush ('-' : name) = Push Minus (I $ T.pack name)
  119         signPush _ = error "Error in matching + and -"
  120         pushCreate lst = map signPush lst
  121         pullCreate lst =
  122             Pull $
  123                 O $
  124                     S.fromList $
  125                         foldl
  126                             ( \buff -> \case
  127                                 (_ : name) -> T.pack name : buff
  128                                 _ -> error "accGen internal error"
  129                             )
  130                             []
  131                             lst
  132      in Acc $ concatMap (\(push, pull) -> pushCreate push ++ [pullCreate pull]) $ partedExpr blocks
  133 
  134 instance Var v => Locks (Acc v x) v where
  135     locks (Acc actions) =
  136         let (lockByActions, lockedActions) = span isPush actions
  137          in [ Lock{locked, lockBy}
  138             | locked <- S.elems $ unionsMap variables lockedActions
  139             , lockBy <- S.elems $ unionsMap variables lockByActions
  140             ]
  141 
  142 instance (Var v, Num x) => FunctionSimulation (Acc v x) v x where
  143     simulate cntx (Acc ops) = snd $ foldl eval (0, []) ops
  144         where
  145             eval (buf, changes) (Push sign (I v))
  146                 | x <- getCntx cntx v =
  147                     case sign of
  148                         Plus -> (buf + x, changes)
  149                         Minus -> (buf - x, changes)
  150             eval (buf, changes) (Pull (O vs)) = (buf, [(v, buf) | v <- S.elems vs] ++ changes)