module UHC.Light.Compiler.Base.TermLike
( AppLike (..)
, appToApp
, BndLike (..)
, RecLike (..)
, rowCanonOrderBy, rowCanonOrder
, appTopApp1
, appRngProdOpt
, appRngParApp
, appConApp, appCon1App
, app1Arr, appArr
, appUnAnn, appUnTop, appUnBind, appUnAnnCanon
, appUnApp
, appUnAppArgs
, appMbApp, appMbConApp
, appMb1MetaArr, appMb1Arr, appMbArr, appUnMetaArrMk, appUnArrMk, appUnMetaArr, appUnArr, appUn1Arr
, appUnArrArgs, appUnArrRes, appUnArrArg
, recUnRecRow
, recRec, recSum, recRecExt, recRecEmp, recSumEmp
, appArrInverse )
where
import UU.Scanner.Position
import UHC.Util.Utils
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Base.HsName
import UHC.Light.Compiler.Base.HsName.Builtin
import Control.Applicative ((<|>))
import Control.Monad
import Data.Maybe

{-# LINE 29 "src/ehc/Base/TermLike.chs" #-}
-- | Application like terms.
--   Note: defaults for Range and non-Range variants are defined using eachother. Only one needs definition.
class AppLike a boundmeta {- ann bnd | a -> ann bnd -}
  | a -> boundmeta
  -- , boundmeta -> a
  where
  ----------
  -- AppLike
  ----------

  -- basic semantics
  app1App           ::  a -> a -> a                         -- single application
  appTop            ::  a -> a                              -- top of multiple apps
  appVar            ::  (Position n,HSNM n) => n -> a       -- variable
  appCon            ::  (Position n,HSNM n) => n -> a       -- constructor
  appPar            ::  a -> a                              -- parenthesis
  -- and the defaults
  app1App           =   appRngApp1   emptyRange
  appTop            =   appRngTop    emptyRange
  appVar            =   appRngVar    emptyRange
  appCon            =   appRngCon    emptyRange
  appPar            =   appRngPar    emptyRange

  -- variation with Range
  appRngApp1        ::  Range -> a -> a -> a
  appRngTop         ::  Range -> a -> a
  appRngVar         ::  (Position n,HSNM n) => Range -> n -> a
  appRngCon         ::  (Position n,HSNM n) => Range -> n -> a
  appRngPar         ::  Range -> a -> a

  -- and the defaults
  appRngApp1   _    =   app1App
  appRngTop    _    =   appTop
  appRngVar    _    =   appVar
  appRngCon    _    =   appCon
  appRngPar    _    =   appPar

  -- inspection/deconstruction
  appMbBind1        :: a -> Maybe (a,a->a)					-- strip binding, if any, also giving reconstruction
  appMbAnn1         :: a -> Maybe (a,a->a)					-- strip annotation, if any, also giving reconstruction
  appMbTop1         :: a -> Maybe (a,a->a)					-- strip top of app, if any, also giving reconstruction
  appMbCanon1       :: a -> Maybe (a,a->a)					-- minimal canonicalization (e.g. strip empty implicits), if any, also giving reconstruction
  appMbCon          :: a -> Maybe (HsName)					-- is con?
  appMbApp1         :: a -> Maybe (a,a)						-- is app?
  appMbDbg          :: a -> Maybe String					-- is dbg?

  -- and the defaults
  appMbBind1        = const Nothing
  appMbAnn1         = const Nothing
  appMbTop1         = appMbAnn1
  appMbCanon1       = const Nothing
  appMbCon          = const Nothing
  appMbApp1         = const Nothing
  appMbDbg          = const Nothing

  -- specialised constructing
  -- | Make application wrapped in top, except for singleton
  appTopApp         ::  [a] -> a
  appProdApp        ::  [a] -> a
  app1MetaArr       :: 	(Maybe HsName,boundmeta) -> a -> a -> a

  -- and the defaults
  appTopApp         =   appRngTopApp emptyRange
  appProdApp    as  =   appConApp (hsnProd (length as)) as
  app1MetaArr _ a r =   appConApp hsnArrow [a,r]

  -- variation with Range
  appRngTopApp      ::  Range -> [a] -> a
  appRngProdApp     ::  Range -> [a] -> a

  -- and the defaults
  appRngTopApp  r [a] = a
  appRngTopApp  r as  = appRngTop r (foldl1 (appRngApp1 r) as)

  appRngProdApp _ as  = appProdApp as            -- to be done

  -- specialised deconstructing
  -- | Wrap 1 arr unpacking into Maybe, together with reconstruction function for toplevel unwrapping
  appMb1ArrMk 		:: a -> Maybe (((HsName,boundmeta),a,a),a->a)

  -- and the defaults
  appMb1ArrMk x
    = do let (x',mktop) = appUnBind $ fst $ appUnAnn x
         (arr,[a,r]) <- appMbConApp x'
         if hsnIsArrow arr then return (((mkHNm "??TermLike.appMb1ArrMk",appDfltBoundmeta a),a,r),mktop) else Nothing

  -- misc: debugging (intended to return a more appropriate value of type 'a')
  appDbg			:: 	String -> a
  appDbg m			=	panic $ "TermLike.appDbg: " ++ m

  -- misc: evaluatedness (i.e. yes/no lazy/thunk)
  -- yes evaluated (no thunk, not lazy)
  appEvl			:: 	a -> a
  appEvl			=	id
  -- not evaluated (yes thunk, yes lazy)
  appNonEvl			:: 	a -> a
  appNonEvl			=	id

  -- fallback, default value
  -- appDflt			:: a
  appDfltBoundmeta  :: a -> boundmeta	-- the 'a' is only required because a fundep boundmeta -> a would be too restrictive
  appDfltBoundmeta _ = panic "TermLike.appDfltBoundmeta not implemented"


{-# LINE 141 "src/ehc/Base/TermLike.chs" #-}
appToApp :: (AppLike a aboundmeta, AppLike b bboundmeta) => a -> Maybe b
appToApp x
  =   c appMbCon appCon x
  <|> c appMbDbg appDbg x
  where c mbUn mk = fmap mk . mbUn

{-# LINE 153 "src/ehc/Base/TermLike.chs" #-}
class {- AppLike a boundmeta => -} BndLike a bndnm where
  bndBndIn			:: bndnm -> MetaLev -> a -> a -> a

{-# LINE 162 "src/ehc/Base/TermLike.chs" #-}
class AppLike a boundmeta => RecLike a boundmeta
  where
  ----------
  -- RecLike
  ----------

  -- constructing
  recRow 			:: a -> AssocL HsName a -> a

  -- default values
  recRowEmp			:: a

  -- and the defaults
  recRowEmp			= appCon hsnRowEmpty

  -- inspection/deconstruction
  recMbRecRow 		:: a -> Maybe a
  recUnRowExts 		:: a -> (a,AssocL HsName a)


{-# LINE 190 "src/ehc/Base/TermLike.chs" #-}
-- | Order on labels, given a comparison function
rowCanonOrderBy :: (o -> o -> Ordering) -> AssocL o a -> AssocL o a
rowCanonOrderBy cmp = sortByOn cmp fst

-- | Order on labels
rowCanonOrder :: AssocL HsName a -> AssocL HsName a
rowCanonOrder = rowCanonOrderBy rowLabCmp
{-# INLINE rowCanonOrder #-}

{-# LINE 205 "src/ehc/Base/TermLike.chs" #-}
-- | Make single application, with top
appTopApp1 :: AppLike a boundmeta {- ann -} => a -> a -> a
appTopApp1 a r = appTopApp [a,r]
{-# INLINE appTopApp1 #-}

{-# LINE 212 "src/ehc/Base/TermLike.chs" #-}
-- | Make product, except for singleton
appRngProdOpt :: AppLike a boundmeta {- ann -} => Range -> [a] -> a
appRngProdOpt r [a] = a
appRngProdOpt r as  = appRngProdApp r as

{-# LINE 219 "src/ehc/Base/TermLike.chs" #-}
-- | Make parenthesized app, except for singleton
appRngParApp :: AppLike a boundmeta {- ann -} => Range -> [a] -> a
appRngParApp r [a] = a
appRngParApp r as  = appRngPar r (appRngTopApp r as)

{-# LINE 230 "src/ehc/Base/TermLike.chs" #-}
-- | Make constructor applied to arguments
appConApp :: (AppLike a boundmeta {- ann -}, Position n, HSNM n) => n -> [a] -> a
appConApp c as = appTopApp (appCon c : as)
{-# INLINE appConApp #-}

-- | See 'appCon1App', just for 1 arg
appCon1App :: (AppLike a boundmeta {- ann -}, Position n, HSNM n) => n -> a -> a
appCon1App c a = appConApp c [a]
{-# INLINE appCon1App #-}

{-# LINE 246 "src/ehc/Base/TermLike.chs" #-}
-- | Make (type) rep for single arrow (i.e. abstraction)
app1Arr :: AppLike a boundmeta {- ann -} => a -> a -> a
app1Arr x y = app1MetaArr (Nothing,appDfltBoundmeta x) x y
{-# INLINE app1Arr #-}

-- | Multiple app1Arr
appArr :: AppLike a boundmeta {- ann -} => [a] -> a -> a
appArr = flip (foldr app1Arr)
{-# INLINE appArr #-}

{-# LINE 262 "src/ehc/Base/TermLike.chs" #-}
-- | Given a single level unwrap, deepnested unwrap top like stuff, also giving reconstruction
appMb2Un :: (a -> Maybe (a,a->a)) -> a -> (a,a->a)
appMb2Un un a
  = case un a of
      Just (a',mk1) -> (a'', mk1 . mk)
                    where (a'',mk) = appMb2Un un a'
      _ -> (a,id)

{-# LINE 272 "src/ehc/Base/TermLike.chs" #-}
-- | Unwrap binding like stuff (i.e. quantifiers), also giving reconstruction
appUnBind :: AppLike a boundmeta {- ann -} => a -> (a,a->a)
appUnBind = appMb2Un appMbBind1
{-# INLINE appUnBind #-}

-- | Unwrap ann like stuff, also giving reconstruction
appUnAnn :: AppLike a boundmeta {- ann -} => a -> (a,a->a)
appUnAnn = appMb2Un appMbAnn1
{-# INLINE appUnAnn #-}

-- | Unwrap ann+canonic like stuff, also giving reconstruction
appUnAnnCanon :: AppLike a boundmeta {- ann -} => a -> (a,a->a)
appUnAnnCanon = appMb2Un (\a -> appMbAnn1 a <|> appMbCanon1 a)

-- | Unwrap top like stuff, also giving reconstruction
appUnTop :: AppLike a boundmeta {- ann -} => a -> (a,a->a)
appUnTop = appMb2Un appMbTop1
{-# INLINE appUnTop #-}

{-# LINE 293 "src/ehc/Base/TermLike.chs" #-}
-- | Unpack app into function and args
appUnApp :: AppLike a boundmeta {- ann -} => a -> (a,[a])
appUnApp x
  = un [] (fst $ appUnTop x)
  where un as x = case appMbApp1 x' of
                    Just (f,a) -> un (a:as) f
                    _          -> (x',as)
                where x' = -- fst $ appMb2Un (\a -> appMbAnn1 a <|> appMbBind1 a) x
                           fst $ appUnBind $ fst $ appUnAnn x

{-# LINE 305 "src/ehc/Base/TermLike.chs" #-}
-- | Unpack app into function and args, args only
appUnAppArgs :: AppLike a boundmeta {- ann -} => a -> [a]
appUnAppArgs = snd . appUnApp
{-# INLINE appUnAppArgs #-}

{-# LINE 312 "src/ehc/Base/TermLike.chs" #-}
-- | Wrap app unpacking into Maybe
appMbApp :: AppLike a boundmeta {- ann -} => a -> Maybe (a,[a])
appMbApp x
  = case appUnApp x of
      u@(_,(_:_)) -> Just u
      _           -> Nothing

-- | Wrap app into constructor name applied to args
appMbConApp :: AppLike a boundmeta {- ann -} => a -> Maybe (HsName,[a])
appMbConApp x
  = do let (f,as) = appUnApp x
       c <- appMbCon $ fst $ appUnAnn f
       return (c,as)


{-# LINE 329 "src/ehc/Base/TermLike.chs" #-}
appMb1MetaArr :: AppLike a boundmeta {- ann -} => a -> Maybe ((HsName,boundmeta),a,a)
appMb1MetaArr = fmap fst . appMb1ArrMk
{-# INLINE appMb1MetaArr #-}

appMb1Arr :: AppLike a boundmeta {- ann -} => a -> Maybe (a,a)
appMb1Arr = fmap (\(_,x,y) -> (x,y)) . appMb1MetaArr
{-# INLINE appMb1Arr #-}

-- | Wrap arr unpacking into Maybe
appMbArr :: AppLike a boundmeta {- ann -} => a -> Maybe ([a],a)
appMbArr x
  = case appUnArr x of
      a@((_:_),_) -> Just a
      _           -> Nothing

-- | Arr unpacking, together with reconstruction function for toplevel unwrapping
appUnMetaArrMk :: AppLike a boundmeta {- ann -} => a -> (([((HsName,boundmeta),a)],a),a->a)
appUnMetaArrMk x
  = case appMb1ArrMk x of
      Just ((m,a,r),mk) -> (((m,a):as,r'),mk)
                        where ((as,r'),_) = appUnMetaArrMk r
      _                 -> (([],x),id)

-- | Arr unpacking, together with reconstruction function for toplevel unwrapping
appUnArrMk :: AppLike a boundmeta {- ann -} => a -> (([a],a),a->a)
appUnArrMk x
  = ((map snd as,r),mk)
  where ((as,r),mk) = appUnMetaArrMk x
{-
  = case appMb1ArrMk x of
      Just ((_,a,r),mk) -> ((a:as,r'),mk)
                        where ((as,r'),_) = appUnArrMk r
      _                 -> (([],x),id)
-}

-- | Arr unpacking into args + res
appUnMetaArr :: AppLike a boundmeta {- ann -} => a -> ([((HsName,boundmeta),a)],a)
appUnMetaArr = fst . appUnMetaArrMk
{-# INLINE appUnMetaArr #-}

-- | Arr unpacking into args + res
appUnArr :: AppLike a boundmeta {- ann -} => a -> ([a],a)
appUnArr = fst . appUnArrMk
{-# INLINE appUnArr #-}

-- | Arr unpacking into arg + res, when failing to unpack arg holds a default
appUn1Arr :: AppLike a boundmeta {- ann -} => a -> (a,a)
appUn1Arr x = maybe (appDbg "appUn1Arr.arg",x) id $ appMb1Arr x
{-# INLINE appUn1Arr #-}

{-# LINE 381 "src/ehc/Base/TermLike.chs" #-}
-- | Arr unpacking, args only
appUnArrArgs :: AppLike a boundmeta {- ann -} => a -> [a]
appUnArrArgs = fst . appUnArr
{-# INLINE appUnArrArgs #-}

-- | Arr unpacking, res only
appUnArrRes :: AppLike a boundmeta {- ann -} => a -> a
appUnArrRes = snd . appUnArr
{-# INLINE appUnArrRes #-}

-- | Arr unpacking, arg only
appUnArrArg :: AppLike a boundmeta {- ann -} => a -> a
appUnArrArg = fst . appUn1Arr
{-# INLINE appUnArrArg #-}

{-# LINE 402 "src/ehc/Base/TermLike.chs" #-}
-- |  inverse type, i.e. a->b gives b->a, a->b->c gives c->(a,b)
appArrInverse :: AppLike a boundmeta {- ann -} => a -> a
appArrInverse x
  = case appUnArrMk x of
      ((   [a]  ,r),mk) -> mk $ [r] `appArr` a
      ((as@(_:_),r),mk) -> mk $ [r] `appArr` appProdApp as
      _                 -> x

{-# LINE 416 "src/ehc/Base/TermLike.chs" #-}
-- | If a row based record, return the row
recUnRecRow :: RecLike a boundmeta => a -> a
recUnRecRow = maybe (panic "recUnRecRow") id . recMbRecRow
{-# INLINE recUnRecRow #-}

{-# LINE 427 "src/ehc/Base/TermLike.chs" #-}
-- | Construct record from labels + terms
recRec :: RecLike a boundmeta => AssocL HsName a -> a
recRec al = hsnRec `appConApp` [recRowEmp `recRow` al]
{-# INLINE recRec #-}

-- | Construct record from labels + terms
recSum :: RecLike a boundmeta => AssocL HsName a -> a
recSum al = hsnSum `appConApp` [recRowEmp `recRow` al]
{-# INLINE recSum #-}

-- | Construct record from record to be extended + labels + terms
recRecExt :: RecLike a boundmeta => a -> AssocL HsName a -> a
recRecExt recd al
  = hsnRec `appConApp` [row `recRow` (exts ++ al)]
  where (row,exts) = recUnRowExts (recUnRecRow recd)

-- | Empty record
recRecEmp :: RecLike a boundmeta => a
recRecEmp = recRec []
{-# INLINE recRecEmp #-}

-- | Empty sum
recSumEmp :: RecLike a boundmeta => a
recSumEmp = recSum []
{-# INLINE recSumEmp #-}