Refine.hs

{-# LANGUAGE TupleSections #-}

module Descript.Sugar.Parse.Refine
  ( freeToImportDeclIn
  , freeToRecordDecl
  , freeToReducer
  , freeToQuery
  , freeToRegValue
  , freeToInput
  , freeToOutput
  , freeToRecordType
  ) where

import Descript.Sugar.Data.Source
import Descript.Sugar.Data.Import
import Descript.Sugar.Data.Reducer
import qualified Descript.Sugar.Data.Value.In as In
import qualified Descript.Sugar.Data.Value.Out as Out
import qualified Descript.Sugar.Data.Value.Reg as Reg
import Descript.Sugar.Data.Value.Gen
import Descript.Sugar.Data.Type
import Descript.Sugar.Data.Atom
import qualified Descript.Free.Data as Free
import Descript.Free.Error
import Descript.Misc

freeToImportDeclIn :: (TaintAnn an)
                   => AbsScope
                   -> Free.ImportDecl an
                   -> ImportDecl an
freeToImportDeclIn scope (Free.ImportDecl ann path isrcs idsts)
  = ImportDecl
  { importDeclAnn = ann
  , importDeclPath = path
  , importDeclSrcImports = map (freeToImportRecordIn scope pscope) isrcs
  , importDeclDstImports = map (freeToImportRecordIn scope pscope) idsts
  }
  where pscope = modulePathScope path

freeToImportRecordIn :: (TaintAnn an)
                     => AbsScope
                     -> AbsScope
                     -> Free.ImportRecord an
                     -> ImportRecord an
freeToImportRecordIn scope pscope (Free.ImportRecord ann from to)
  = ImportRecord ann (FSymbol pscope from) (FSymbol scope to)

-- | Refines to a record declaration.
freeToRecordDecl :: Free.RecordDecl Range -> RefineResult (RecordDecl Range)
freeToRecordDecl (Free.RecordDecl r recordType) = RecordDecl r <$> freeToRecordType recordType

-- | Refines to a reducer.
freeToReducer :: Free.Reducer Range -> RefineResult (Reducer Range)
freeToReducer (Free.Reducer r input' output')
  = Reducer r <$> freeToInput input' <*> freeToOutput output'

-- | Refines to a query.
freeToQuery :: Free.Query Range -> RefineResult (Query Range)
freeToQuery (Free.Query r val) = Query r <$> freeToRegValue val

-- | Refines to a regular value.
freeToRegValue :: Free.Value Range -> RefineResult (Reg.Value Range)
freeToRegValue (Free.Value r parts) = Value r <$> freeToParts parts

-- | Refines to regular parts.
freeToParts :: [Free.Part Range] -> RefineResult [Reg.Part Range]
freeToParts = traverse freeToPart

-- | Refines to a regular part.
freeToPart :: Free.Part Range -> RefineResult (Reg.Part Range)
freeToPart (Free.PartPrim prim) = Success $ Reg.PartPrim prim
freeToPart (Free.PartRecord record) = Reg.PartRecord <$> freeToRecord record
freeToPart x@(Free.PartPropPath (PropPath r _))
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "primitive or record"
  , actual = "property path"
  , actualPr = pprintStr x
  }

-- | Refines to a regular record.
freeToRecord :: Free.Record Range -> RefineResult (Reg.Record Range)
freeToRecord record
    = Record (Free.recordAnn record) (Free.head record)
  <$> freeToProperties (Free.properties record)

-- | Refines to regular properties.
freeToProperties :: [Free.Property Range] -> RefineResult [Reg.Property Range]
freeToProperties = traverse freeToProperty

-- | Refines to a regular property.
freeToProperty :: Free.Property Range -> RefineResult (Reg.Property Range)
freeToProperty (Free.PropertySingle val)
  = Property r Nothing <$> freeToRegValue val
  where r = getAnn val
freeToProperty (Free.PropertyDef r key val)
  = Property r (Just key) <$> freeToRegValue val

-- | Refines to Range input value.
freeToInput :: Free.Value Range -> RefineResult (In.Value Range)
freeToInput (Free.Value r parts) = Value r <$> freeToInParts parts

-- | Refines to input parts.
freeToInParts :: [Free.Part Range] -> RefineResult [In.Part Range]
freeToInParts = traverse freeToInPart

-- | Refines to Range input part.
freeToInPart :: Free.Part Range -> RefineResult (In.Part Range)
freeToInPart (Free.PartPrim prim) = Success $ In.PartPrim prim
freeToInPart (Free.PartRecord record)
  | isFreePrimType record = In.PartPrimType <$> freeToPrimType record
  | otherwise = In.PartRecord <$> freeToInRecord record
freeToInPart x@(Free.PartPropPath (PropPath r _))
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "primitive, primitive type, or record"
  , actual = "property path"
  , actualPr = pprintStr x
  }

isFreePrimType :: Free.Record Range -> Bool
isFreePrimType = isInjSymbol . Free.head

freeToPrimType :: Free.Record Range -> RefineResult (PrimType Range)
freeToPrimType record
  | null $ Free.properties record = freeSymbolToPrimType (Free.recordAnn record) $ Free.head record
  | otherwise = Failure $ entireRefineDiff (Free.recordAnn record) LocalRefineDiff
  { expected = "primitive type"
  , actual = "injected function application"
  , actualPr = pprintStr record
  }

freeSymbolToPrimType :: Range -> Symbol Range -> RefineResult (PrimType Range)
freeSymbolToPrimType r (Symbol _ label) = freeSymbolStrToPrimType r label

freeSymbolStrToPrimType :: Range -> String -> RefineResult (PrimType Range)
freeSymbolStrToPrimType r "#Number" = Success $ PrimTypeNumber r
freeSymbolStrToPrimType r "#String" = Success $ PrimTypeString r
freeSymbolStrToPrimType r x
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "#Number or #String"
  , actual = "non-existent primitive type"
  , actualPr = x
  }

-- | Refines to Range input record.
freeToInRecord :: Free.Record Range -> RefineResult (In.Record Range)
freeToInRecord record
    = Record (Free.recordAnn record) (Free.head record)
  <$> freeToInProperties (Free.properties record)

-- | Refines to input properties.
freeToInProperties :: [Free.Property Range] -> RefineResult [In.Property Range]
freeToInProperties = traverse freeToInProperty

-- | Refines to Range input property.
freeToInProperty :: Free.Property Range -> RefineResult (In.Property Range)
freeToInProperty (Free.PropertySingle x)
  = case Free.valueToPropKey x of
         Nothing -> Property r Nothing . In.JustValue <$> freeToInput x
         Just key -> Success $ Property r (Just key) In.NothingValue
  where r = getAnn x
freeToInProperty (Free.PropertyDef r key val)
  = Property r (Just key) . In.JustValue <$> freeToInput val

-- | Refines to Range output value.
freeToOutput :: Free.Value Range -> RefineResult (Out.Value Range)
freeToOutput (Free.Value r parts) = Value r <$> freeToOutParts parts

-- | Refines to output parts.
freeToOutParts :: [Free.Part Range] -> RefineResult [Out.Part Range]
freeToOutParts = traverse freeToOutPart

-- | Refines to Range output part.
freeToOutPart :: Free.Part Range -> RefineResult (Out.Part Range)
freeToOutPart (Free.PartPrim prim) = Success $ Out.PartPrim prim
freeToOutPart (Free.PartRecord record)
  | isFreeInjApp record = Out.PartInjApp <$> freeToInjApp record
  | otherwise = Out.PartRecord <$> freeToOutRecord record
freeToOutPart (Free.PartPropPath path) = Success $ Out.PartPropPath path

isFreeInjApp :: Free.Record Range -> Bool
isFreeInjApp = isInjSymbol . Free.head

freeToInjApp :: Free.Record Range -> RefineResult (Out.InjApp Range)
freeToInjApp record
    = Out.InjApp (Free.recordAnn record) (forceToInjSymbol $ Free.head record)
  <$> freeToInjParams (Free.properties record)

freeToInjParams :: [Free.Property Range] -> RefineResult [Out.InjParam Range]
freeToInjParams = freeToInjParamsFromIdx 0

freeToInjParamsFromIdx :: Int -> [Free.Property Range] -> RefineResult [Out.InjParam Range]
freeToInjParamsFromIdx _ [] = Success []
freeToInjParamsFromIdx n (x : xs)
  = (:) <$> freeToInjParamAtIdx n x <*> freeToInjParamsFromIdx (n + 1) xs

freeToInjParamAtIdx :: Int -> Free.Property Range -> RefineResult (Out.InjParam Range)
freeToInjParamAtIdx _ (Free.PropertySingle val)
  = Out.InjParam r <$> freeToOutput val
  where r = getAnn val
freeToInjParamAtIdx n (Free.PropertyDef r key val)
  | key /@= propKey
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "\"" ++ summary propKey ++ "\""
  , actual = "\"" ++ summary key ++ "\""
  , actualPr = pprintStr key
  }
  | otherwise = Out.InjParam r <$> freeToOutput val
  where propKey = Out.idxPropKeys !! n

-- | Refines to Range output record.
freeToOutRecord :: Free.Record Range -> RefineResult (Out.Record Range)
freeToOutRecord record
    = Record (Free.recordAnn record) (Free.head record)
  <$> freeToOutProperties (Free.properties record)

-- | Refines to output properties.
freeToOutProperties :: [Free.Property Range] -> RefineResult [Out.Property Range]
freeToOutProperties = traverse freeToOutProperty

-- | Refines to Range output property.
freeToOutProperty :: Free.Property Range -> RefineResult (Out.Property Range)
freeToOutProperty (Free.PropertySingle val)
  = Property r Nothing <$> freeToOutput val
  where r = getAnn val
freeToOutProperty (Free.PropertyDef r key val)
  = Property r (Just key) <$> freeToOutput val

-- | Refines to a record type.
freeToRecordType :: Free.Value Range -> RefineResult (RecordType Range)
freeToRecordType (Free.Value _ [Free.PartRecord record]) = freeRecordToRecordType record
freeToRecordType x@(Free.Value r _)
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "record"
  , actual = describeValueAsPart x
  , actualPr = pprintStr x
  }

-- | Refines a record to a record type.
freeRecordToRecordType :: Free.Record Range -> RefineResult (RecordType Range)
freeRecordToRecordType record
    = RecordType (Free.recordAnn record) (Free.head record)
  <$> freeToRecordTypeProperties (Free.properties record)

-- | Refines to record type "properties" (property declarations).
freeToRecordTypeProperties :: [Free.Property Range] -> RefineResult [Symbol Range]
freeToRecordTypeProperties = traverse freeToRecordTypeProperty

-- | Refines to a record type "property" (property declaration).
freeToRecordTypeProperty :: Free.Property Range -> RefineResult (Symbol Range)
freeToRecordTypeProperty (Free.PropertySingle x)
  = case Free.valueToPropKey x of
    Nothing
      -> Failure $ entireRefineDiff r LocalRefineDiff
       { expected = "property declaration"
       , actual = "value"
       , actualPr = pprintStr x
       }
    Just key -> Success key
  where r = getAnn x
freeToRecordTypeProperty x@(Free.PropertyDef r _ _)
  = Failure $ entireRefineDiff r LocalRefineDiff
  { expected = "property declaration"
  , actual = "property definition"
  , actualPr = pprintStr x
  }

describeValueAsPart :: Free.Value Range -> String
describeValueAsPart (Free.Value _ [Free.PartPrim _]) = "primitive"
describeValueAsPart (Free.Value _ [Free.PartRecord _]) = "record"
describeValueAsPart (Free.Value _ [Free.PartPropPath _]) = "path"
describeValueAsPart (Free.Value _ []) = "empty"
describeValueAsPart (Free.Value _ _) = "union"