{-# LANGUAGE OverloadedStrings #-}

module Jacinda.Check.Field ( cF, LErr (..) ) where

import           A
import           Control.Applicative (Alternative (..))
import           Control.Exception   (Exception)
import           Data.Foldable       (asum)
import           Prettyprinter       (Pretty (..), squotes, (<+>))

data LErr = NF (E T) | TS (E T) | RS (E T)

instance Pretty LErr where
    pretty :: forall ann. LErr -> Doc ann
pretty (NF E T
e) = Doc ann
"Naked field in expression" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (E T -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. E T -> Doc ann
pretty E T
e)
    pretty (TS E T
e) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (E T -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. E T -> Doc ann
pretty E T
e) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Tuples cannot have streams."
    pretty (RS E T
e) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (E T -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. E T -> Doc ann
pretty E T
e) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"Records cannot have streams."

instance Show LErr where show :: LErr -> String
show=Doc Any -> String
forall a. Show a => a -> String
show(Doc Any -> String) -> (LErr -> Doc Any) -> LErr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LErr -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. LErr -> Doc ann
pretty

instance Exception LErr where

cF :: E T -> Maybe LErr
cF :: E T -> Maybe LErr
cF e :: E T
e@(Tup (TyTup [T]
ts) [E T]
_) | (T -> Bool) -> [T] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any T -> Bool
isS [T]
ts = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
TS E T
e); cF e :: E T
e@(Rec (TyRec NmMap T
rs) [(Nm T, E T)]
_) | (T -> Bool) -> NmMap T -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any T -> Bool
isS NmMap T
rs = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
RS E T
e)
cF e :: E T
e@Field{} = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e); cF e :: E T
e@AllField{} = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e); cF e :: E T
e@LastField{} = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e); cF e :: E T
e@FieldList{} = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e)
cF e :: E T
e@(NB T
_ N
Ix) = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e); cF e :: E T
e@(NB T
_ N
Nf) = LErr -> Maybe LErr
forall a. a -> Maybe a
Just (E T -> LErr
NF E T
e)
cF IParseCol{} = Maybe LErr
forall a. Maybe a
Nothing; cF FParseCol{} = Maybe LErr
forall a. Maybe a
Nothing; cF ParseCol{} = Maybe LErr
forall a. Maybe a
Nothing; cF Column{} = Maybe LErr
forall a. Maybe a
Nothing
cF AllColumn{} = Maybe LErr
forall a. Maybe a
Nothing; cF FParseAllCol{} = Maybe LErr
forall a. Maybe a
Nothing; cF IParseAllCol{} = Maybe LErr
forall a. Maybe a
Nothing; cF ParseAllCol{} = Maybe LErr
forall a. Maybe a
Nothing
cF Guarded{} = Maybe LErr
forall a. Maybe a
Nothing; cF Implicit{} = Maybe LErr
forall a. Maybe a
Nothing
cF Lit{} = Maybe LErr
forall a. Maybe a
Nothing; cF RegexLit{} = Maybe LErr
forall a. Maybe a
Nothing;
cF NB{} = Maybe LErr
forall a. Maybe a
Nothing; cF UB{} = Maybe LErr
forall a. Maybe a
Nothing; cF BB{} = Maybe LErr
forall a. Maybe a
Nothing; cF TB{} = Maybe LErr
forall a. Maybe a
Nothing
cF Var{} = Maybe LErr
forall a. Maybe a
Nothing; cF (Tup T
_ [E T]
es) = (E T -> Maybe LErr) -> [E T] -> Maybe LErr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative E T -> Maybe LErr
cF [E T]
es; cF (Anchor T
_ [E T]
es) = (E T -> Maybe LErr) -> [E T] -> Maybe LErr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative E T -> Maybe LErr
cF [E T]
es
cF (Arr T
_ Vector (E T)
es) = (E T -> Maybe LErr) -> Vector (E T) -> Maybe LErr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative E T -> Maybe LErr
cF Vector (E T)
es; cF (Rec T
_ [(Nm T, E T)]
es) = ((Nm T, E T) -> Maybe LErr) -> [(Nm T, E T)] -> Maybe LErr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative (E T -> Maybe LErr
cF(E T -> Maybe LErr)
-> ((Nm T, E T) -> E T) -> (Nm T, E T) -> Maybe LErr
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Nm T, E T) -> E T
forall a b. (a, b) -> b
snd) [(Nm T, E T)]
es; cF (EApp T
_ E T
e E T
e') = E T -> Maybe LErr
cF E T
e Maybe LErr -> Maybe LErr -> Maybe LErr
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> E T -> Maybe LErr
cF E T
e'
cF (Cond T
_ E T
p E T
e E T
e') = E T -> Maybe LErr
cF E T
p Maybe LErr -> Maybe LErr -> Maybe LErr
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> E T -> Maybe LErr
cF E T
e Maybe LErr -> Maybe LErr -> Maybe LErr
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> E T -> Maybe LErr
cF E T
e'; cF (OptionVal T
_ Maybe (E T)
e) = (E T -> Maybe LErr) -> Maybe (E T) -> Maybe LErr
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative E T -> Maybe LErr
cF Maybe (E T)
e
cF (Lam T
_ Nm T
_ E T
e) = E T -> Maybe LErr
cF E T
e; cF Let{} = String -> Maybe LErr
forall a. HasCallStack => String -> a
error String
"Inlining unexpectedly failed?"
cF RC{} = String -> Maybe LErr
forall a. HasCallStack => String -> a
error String
"Sanity check failed. Regex should not be compiled at this time."
cF Dfn{} = Maybe LErr
forall {a}. a
desugar; cF Paren{} = Maybe LErr
forall {a}. a
desugar; cF ResVar{} = Maybe LErr
forall {a}. a
desugar
cF RwB{} = Maybe LErr
forall {a}. a
desugar; cF RwT{} = Maybe LErr
forall {a}. a
desugar

isS :: T -> Bool
isS :: T -> Bool
isS (TyB TB
TyStream:$T
_) = Bool
True; isS T
_ = Bool
False

foldMapAlternative :: (Traversable t, Alternative f) => (a -> f b) -> t a -> f b
foldMapAlternative :: forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Alternative f) =>
(a -> f b) -> t a -> f b
foldMapAlternative a -> f b
f t a
xs = t (f b) -> f b
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (a -> f b
f (a -> f b) -> t a -> t (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t a
xs)

desugar :: a
desugar = String -> a
forall a. HasCallStack => String -> a
error String
"Internal error. Should have been desugared by now."