never executed always true always false

    1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DeriveFunctor, DeriveTraversable, DeriveFoldable #-}
    2 
    3 module Conjure.Language.Expression.Op.Indexing where
    4 
    5 import Conjure.Prelude
    6 import Conjure.Language.Expression.Op.Internal.Common
    7 
    8 import qualified Data.Aeson as JSON             -- aeson
    9 import qualified Data.Aeson.KeyMap as KM
   10 
   11 import qualified Data.Vector as V               -- vector
   12 
   13 -- pretty
   14 import Conjure.Language.Pretty as Pr ( cat )
   15 
   16 
   17 data OpIndexing x = OpIndexing x x
   18     deriving (Eq, Ord, Show, Data, Functor, Traversable, Foldable, Typeable, Generic)
   19 
   20 instance Serialize x => Serialize (OpIndexing x)
   21 instance Hashable  x => Hashable  (OpIndexing x)
   22 instance ToJSON    x => ToJSON    (OpIndexing x) where toJSON = genericToJSON jsonOptions
   23 instance FromJSON  x => FromJSON  (OpIndexing x) where parseJSON = genericParseJSON jsonOptions
   24 
   25 instance (TypeOf x, Pretty x, ExpressionLike x, ReferenceContainer x) => TypeOf (OpIndexing x) where
   26     typeOf p@(OpIndexing m i) = do
   27         tyM <- typeOf m
   28         tyI <- typeOf i
   29         case tyM of
   30             TypeMatrix tyIndex inn
   31                 | typesUnify [tyIndex, tyI] -> return inn
   32                 | otherwise -> failDoc $ "Indexing with inappropriate type:" <++> vcat
   33                     [ "The expression:"  <+> pretty p
   34                     , "Indexing:"        <+> pretty m
   35                     , "Expected type of index:" <+> pretty tyIndex
   36                     , "Actual type of index  :" <+> pretty tyI
   37                     ]
   38             TypeList inn
   39                 | typesUnify [TypeInt TagInt, tyI] -> return inn
   40                 | otherwise -> failDoc $ "Indexing with inappropriate type:" <++> vcat
   41                     [ "The expression:"  <+> pretty p
   42                     , "Indexing:"        <+> pretty m
   43                     , "Expected type of index:" <+> pretty (TypeInt TagInt)
   44                     , "Actual type of index  :" <+> pretty tyI
   45                     ]
   46             TypeTuple inns   -> do
   47                 TypeInt t <- typeOf i
   48                 case t of
   49                     TagInt -> return ()
   50                     _ -> failDoc $ "Tuples cannot be indexed by enums/unnameds:" <++> pretty p
   51                 case intOut "OpIndexing" i of
   52                     Nothing -> failDoc $ "Tuples can only be indexed by constants:" <++> pretty p
   53                     Just iInt | iInt <= 0 || iInt > genericLength inns ->
   54                                     failDoc $ "Out of bounds tuple indexing:" <++> pretty p
   55                               | otherwise -> return (at inns (fromInteger (iInt-1)))
   56             TypeRecord inns  -> do
   57                 nm <- nameOut i
   58                 case lookup nm inns of
   59                     Nothing -> failDoc $ "Record indexing with non-member field:" <++> vcat
   60                         [ "The expression:" <+> pretty p
   61                         , "Indexing:"       <+> pretty m
   62                         , "With type:"      <+> pretty tyM
   63                         ]
   64                     Just ty -> return ty
   65             TypeVariant inns -> do
   66                 nm <- nameOut i
   67                 case lookup nm inns of
   68                     Nothing -> failDoc $ "Variant indexing with non-member field:" <++> vcat
   69                         [ "The expression:" <+> pretty p
   70                         , "Indexing:"       <+> pretty m
   71                         , "With type:"      <+> pretty tyM
   72                         ]
   73                     Just ty -> return ty
   74             _ -> failDoc $ "Indexing something other than a matrix or a tuple:" <++> vcat
   75                     [ "The expression:" <+> pretty p
   76                     , "Indexing:"       <+> pretty m
   77                     , "With type:"      <+> pretty tyM
   78                     ]
   79 
   80 instance SimplifyOp OpIndexing x where
   81     simplifyOp _ = na "simplifyOp{OpIndexing}"
   82 
   83 instance Pretty x => Pretty (OpIndexing x) where
   84     prettyPrec _ (OpIndexing a b) = Pr.cat [pretty a, nest 4 (prBrackets (pretty b))]
   85 
   86 instance VarSymBreakingDescription x => VarSymBreakingDescription (OpIndexing x) where
   87     varSymBreakingDescription (OpIndexing a b) = JSON.Object $ KM.fromList
   88         [ ("type", JSON.String "OpIndexing")
   89         , ("children", JSON.Array $ V.fromList
   90             [ varSymBreakingDescription a
   91             , varSymBreakingDescription b
   92             ])
   93         ]